From 2560b63dcc98a6a6b5e2f938d8279d9bb4627052 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 6 May 2015 17:46:08 -0400 Subject: - Removed all the unnecesary comments. - Made some changes to the way type-checking is performed on variants, records & tuples in order to improve the speed of type-checking. --- src/lux.clj | 10 - src/lux/analyser.clj | 46 ++-- src/lux/analyser/base.clj | 13 +- src/lux/analyser/case.clj | 188 ++++++++--------- src/lux/analyser/host.clj | 35 +--- src/lux/analyser/lambda.clj | 7 - src/lux/analyser/lux.clj | 267 +++++++---------------- src/lux/analyser/module.clj | 29 ++- src/lux/base.clj | 74 +++---- src/lux/compiler.clj | 500 +++++++++++++++++++++----------------------- src/lux/compiler/base.clj | 178 ++++++++-------- src/lux/compiler/case.clj | 9 +- src/lux/compiler/host.clj | 7 +- src/lux/compiler/lambda.clj | 20 +- src/lux/compiler/lux.clj | 16 +- src/lux/host.clj | 5 +- src/lux/lexer.clj | 16 +- src/lux/parser.clj | 17 +- src/lux/reader.clj | 13 +- src/lux/type.clj | 241 +++++++-------------- 20 files changed, 689 insertions(+), 1002 deletions(-) diff --git a/src/lux.clj b/src/lux.clj index de302b260..62e9d14f9 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -11,15 +11,5 @@ (comment ;; TODO: Finish total-locals - (time (&compiler/compile-all (&/|list "program"))) - - (time (&compiler/compile-all (&/|list "lux"))) - (System/gc) - (time (&compiler/compile-all (&/|list "lux" "test2"))) - - ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2 - ;; jar cvf program.jar output/*.class output/program && java -cp "program.jar" program - ;; cd output && jar cvf test2.jar * && java -cp "test2.jar" test2 && cd .. - ;; cd output && jar cvf program.jar * && java -cp "program.jar" program && cd .. ) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index e2cdb83ce..eefb5b41c 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -88,9 +88,7 @@ ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]] - (do ;; (when (= "if" ?name) - ;; (prn "if" (&/show-ast ?value))) - (&&lux/analyse-def analyse ?name ?value)) + (&&lux/analyse-def analyse ?name ?value) [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "declare-macro'"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]] @@ -458,10 +456,6 @@ (fail ""))) (defn ^:private analyse-basic-ast [analyse eval! exo-type token] - ;; (prn 'analyse-basic-ast (aget token 0)) - ;; (when (= "lux;Tag" (aget token 0)) - ;; (prn 'analyse-basic-ast/tag (aget token 1))) - ;; (prn 'analyse-basic-ast token (&/show-ast token)) (fn [state] (matchv ::M/objects [((aba1 analyse eval! exo-type token) state)] [["lux;Right" [state* output]]] @@ -472,36 +466,53 @@ [["lux;Right" [state* output]]] (return* state* output) - [_] + [["lux;Left" ""]] (matchv ::M/objects [((aba3 analyse eval! exo-type token) state)] [["lux;Right" [state* output]]] (return* state* output) - [_] + [["lux;Left" ""]] (matchv ::M/objects [((aba4 analyse eval! exo-type token) state)] [["lux;Right" [state* output]]] (return* state* output) - [_] + [["lux;Left" ""]] (matchv ::M/objects [((aba5 analyse eval! exo-type token) state)] [["lux;Right" [state* output]]] (return* state* output) - [_] + [["lux;Left" ""]] (matchv ::M/objects [((aba6 analyse eval! exo-type token) state)] [["lux;Right" [state* output]]] (return* state* output) - - [_] + + [["lux;Left" ""]] (matchv ::M/objects [((aba7 analyse eval! exo-type token) state)] [["lux;Right" [state* output]]] (return* state* output) [_] - (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))))))))))) + (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))) + + [_] + (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))) + + [_] + (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))) + + [_] + (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))) + + [_] + (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))) + + [_] + (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))) + + [_] + (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))))) (defn ^:private analyse-ast [eval! exo-type token] - ;; (prn 'analyse-ast (aget token 0)) (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?ident]]] ?values]]]]]] (do (assert (= 1 (&/|length ?values)) "[Analyser Error] Can only tag 1 value.") @@ -509,15 +520,12 @@ [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [?fn ?args]]]]]] (fn [state] - ;; (prn 'analyse-ast '(&/show-ast ?fn) (&/show-ast ?fn)) (matchv ::M/objects [((&type/with-var #(&&/analyse-1 (partial analyse-ast eval!) % ?fn)) state)] [["lux;Right" [state* =fn]]] ((&&lux/analyse-apply (partial analyse-ast eval!) exo-type =fn ?args) state*) [_] - (do ;; (prn 'analyse-ast/token (aget token 0) (&/show-state state)) - ;; (prn 'NOT_A_FUNCTION (&/show-ast ?fn)) - ((analyse-basic-ast (partial analyse-ast eval!) eval! exo-type token) state)))) + ((analyse-basic-ast (partial analyse-ast eval!) eval! exo-type token) state))) [_] (analyse-basic-ast (partial analyse-ast eval!) eval! exo-type token))) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 9913da4ae..b16025349 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -6,21 +6,18 @@ ;; [Exports] (defn expr-type [syntax+] - ;; (prn 'expr-type syntax+) - ;; (prn 'expr-type (aget syntax+ 0)) (matchv ::M/objects [syntax+] [[_ type]] (return type))) (defn analyse-1 [analyse exo-type elem] (|do [output (analyse exo-type elem)] - (do ;; (prn 'analyse-1 (aget output 0)) - (matchv ::M/objects [output] - [["lux;Cons" [x ["lux;Nil" _]]]] - (return x) + (matchv ::M/objects [output] + [["lux;Cons" [x ["lux;Nil" _]]]] + (return x) - [_] - (fail "[Analyser Error] Can't expand to other than 1 element."))))) + [_] + (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn resolved-ident [ident] (|let [[?module ?name] ident] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index ea767d11c..cdcf40e0f 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -19,105 +19,102 @@ (&type/actual-type type))) (defn ^:private analyse-pattern [value-type pattern kont] - ;; (prn 'analyse-pattern/pattern (aget pattern 0) (aget pattern 1) (alength (aget pattern 1))) (matchv ::M/objects [pattern] [["lux;Meta" [_ pattern*]]] - ;; (assert false) - (do ;; (prn 'analyse-pattern/pattern* (aget pattern* 0)) - (matchv ::M/objects [pattern*] - [["lux;Symbol" ?ident]] - (|do [=kont (&env/with-local (&/ident->text ?ident) value-type - kont) - idx &env/next-local-idx] - (return (&/T (&/V "StoreTestAC" idx) =kont))) - - [["lux;Bool" ?value]] - (|do [_ (&type/check value-type &type/Bool) - =kont kont] - (return (&/T (&/V "BoolTestAC" ?value) =kont))) - - [["lux;Int" ?value]] - (|do [_ (&type/check value-type &type/Int) - =kont kont] - (return (&/T (&/V "IntTestAC" ?value) =kont))) - - [["lux;Real" ?value]] - (|do [_ (&type/check value-type &type/Real) - =kont kont] - (return (&/T (&/V "RealTestAC" ?value) =kont))) - - [["lux;Char" ?value]] - (|do [_ (&type/check value-type &type/Char) - =kont kont] - (return (&/T (&/V "CharTestAC" ?value) =kont))) - - [["lux;Text" ?value]] - (|do [_ (&type/check value-type &type/Text) - =kont kont] - (return (&/T (&/V "TextTestAC" ?value) =kont))) - - [["lux;Tuple" ?members]] - (matchv ::M/objects [value-type] - [["lux;TupleT" ?member-types]] - (if (not (= (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Analyser 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))))) + (matchv ::M/objects [pattern*] + [["lux;Symbol" ?ident]] + (|do [=kont (&env/with-local (&/ident->text ?ident) value-type + kont) + idx &env/next-local-idx] + (return (&/T (&/V "StoreTestAC" idx) =kont))) + + [["lux;Bool" ?value]] + (|do [_ (&type/check value-type &type/Bool) + =kont kont] + (return (&/T (&/V "BoolTestAC" ?value) =kont))) + + [["lux;Int" ?value]] + (|do [_ (&type/check value-type &type/Int) + =kont kont] + (return (&/T (&/V "IntTestAC" ?value) =kont))) + + [["lux;Real" ?value]] + (|do [_ (&type/check value-type &type/Real) + =kont kont] + (return (&/T (&/V "RealTestAC" ?value) =kont))) + + [["lux;Char" ?value]] + (|do [_ (&type/check value-type &type/Char) + =kont kont] + (return (&/T (&/V "CharTestAC" ?value) =kont))) + + [["lux;Text" ?value]] + (|do [_ (&type/check value-type &type/Text) + =kont kont] + (return (&/T (&/V "TextTestAC" ?value) =kont))) + + [["lux;Tuple" ?members]] + (matchv ::M/objects [value-type] + [["lux;TupleT" ?member-types]] + (if (not (= (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Analyser 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 "[Analyser Error] Tuple requires tuple-type.")) + + [["lux;Record" ?slots]] + (|do [value-type* (resolve-type value-type)] + (matchv ::M/objects [value-type*] + [["lux;RecordT" ?slot-types]] + (if (not (= (&/|length ?slot-types) (&/|length ?slots))) + (fail (str "[Analyser error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* slot] + (|let [[sn sv] slot] + (matchv ::M/objects [sn] + [["lux;Meta" [_ ["lux;Tag" ?ident]]]] + (|do [=tag (&&/resolved-ident ?ident)] + (if-let [=slot-type (&/|get =tag ?slot-types)] + (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] + (return (&/T (&/|put =tag =test =tests) =kont))) + (fail (str "[Pattern-Matching Error] Record-type lacks slot: " =tag)))) + + [_] + (fail (str "[Pattern-Matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) (|do [=kont kont] - (return (&/T (&/|list) =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V "TupleTestAC" =tests) =kont)))) + (return (&/T (&/|table) =kont))) + (&/|reverse ?slots))] + (return (&/T (&/V "RecordTestAC" =tests) =kont)))) [_] - (fail "[Analyser Error] Tuple requires tuple-type.")) - - [["lux;Record" ?slots]] - (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;RecordT" ?slot-types]] - (if (not (= (&/|length ?slot-types) (&/|length ?slots))) - (fail (str "[Analyser error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* slot] - (|let [[sn sv] slot] - (matchv ::M/objects [sn] - [["lux;Meta" [_ ["lux;Tag" ?ident]]]] - (|do [=tag (&&/resolved-ident ?ident)] - (if-let [=slot-type (&/|get =tag ?slot-types)] - (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] - (return (&/T (&/|put =tag =test =tests) =kont))) - (fail (str "[Pattern-Matching Error] Record-type lacks slot: " =tag)))) - - [_] - (fail (str "[Pattern-Matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) - (|do [=kont kont] - (return (&/T (&/|table) =kont))) - (&/|reverse ?slots))] - (return (&/T (&/V "RecordTestAC" =tests) =kont)))) - - [_] - (fail "[Analyser Error] Record requires record-type."))) - - [["lux;Tag" ?ident]] - (|do [=tag (&&/resolved-ident ?ident) - value-type* (resolve-type value-type) - case-type (&type/variant-case =tag value-type*) - [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) - (&/V "lux;Tuple" (&/|list)))) - kont)] - (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) - - [["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?ident]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]] - (|do [=tag (&&/resolved-ident ?ident) - value-type* (resolve-type value-type) - case-type (&type/variant-case =tag value-type*) - [=test =kont] (analyse-pattern case-type ?value - kont)] - (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) - )))) + (fail "[Analyser Error] Record requires record-type."))) + + [["lux;Tag" ?ident]] + (|do [=tag (&&/resolved-ident ?ident) + value-type* (resolve-type value-type) + case-type (&type/variant-case =tag value-type*) + [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) + (&/V "lux;Tuple" (&/|list)))) + kont)] + (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) + + [["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?ident]]] + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]] + (|do [=tag (&&/resolved-ident ?ident) + value-type* (resolve-type value-type) + case-type (&type/variant-case =tag value-type*) + [=test =kont] (analyse-pattern case-type ?value + kont)] + (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) + ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] (|do [pattern+body (analyse-pattern value-type pattern @@ -219,7 +216,6 @@ )))) (defn ^:private check-totality [value-type struct] - ;; (prn 'check-totality (aget value-type 0) (aget struct 0) (&type/show-type value-type)) (matchv ::M/objects [struct] [["BoolTotal" [?total ?values]]] (return (or ?total @@ -296,10 +292,8 @@ (analyse-branch analyse exo-type value-type pattern body patterns))) (&/|list) branches) - ;; :let [_ (prn 'PRE_MERGE_TOTALS)] struct (&/fold% merge-total (&/V "DefaultTotal" false) patterns) ? (check-totality value-type struct)] (if ? - ;; (return (&/|reverse patterns)) (return patterns) (fail "[Pattern-maching error] Pattern-matching is non-total.")))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 3c9e3ce3f..d57493439 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -21,7 +21,6 @@ (defn ^:private analyse-1+ [analyse ?token] (&type/with-var (fn [$var] - ;; (prn 'analyse-1+ (aget $var 1) (&/show-ast ?token)) (|do [=expr (&&/analyse-1 analyse $var ?token)] (matchv ::M/objects [=expr] [[?item ?type]] @@ -77,10 +76,7 @@ (defn analyse-jvm-getstatic [analyse ?class ?field] (|do [=class (&host/full-class-name ?class) - ;; :let [_ (prn 'analyse-jvm-getstatic/=class =class)] - =type (&host/lookup-static-field =class ?field) - ;; :let [_ (prn 'analyse-jvm-getstatic/=type =type)] - ] + =type (&host/lookup-static-field =class ?field)] (return (&/|list (&/T (&/V "jvm-getstatic" (&/T =class ?field)) =type))))) (defn analyse-jvm-getfield [analyse ?class ?field ?object] @@ -91,9 +87,7 @@ (defn analyse-jvm-putstatic [analyse ?class ?field ?value] (|do [=class (&host/full-class-name ?class) - ;; :let [_ (prn 'analyse-jvm-getstatic/=class =class)] =type (&host/lookup-static-field =class ?field) - ;; :let [_ (prn 'analyse-jvm-getstatic/=type =type)] =value (&&/analyse-1 analyse ?value)] (return (&/|list (&/T (&/V "jvm-putstatic" (&/T =class ?field =value)) =type))))) @@ -113,21 +107,14 @@ (do-template [ ] (defn [analyse ?class ?method ?classes ?object ?args] - ;; (prn ' ?class ?method) (|do [=class (&host/full-class-name ?class) - ;; :let [_ (prn 'analyse-jvm-invokevirtual/=class =class)] =classes (&/map% &host/extract-jvm-param ?classes) - ;; :let [_ (prn 'analyse-jvm-invokevirtual/=classes =classes)] =return (&host/lookup-virtual-method =class ?method =classes) - ;; :let [_ (prn 'analyse-jvm-invokevirtual/=return =return)] =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) - ;; :let [_ (prn 'analyse-jvm-invokevirtual/=object =object)] =args (&/map% (fn [c+o] (|let [[?c ?o] c+o] (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o))) - (&/zip2 =classes ?args)) - ;; :let [_ (prn 'analyse-jvm-invokevirtual/=args =args)] - ] + (&/zip2 =classes ?args))] (return (&/|list (&/T (&/V (&/T =class ?method =classes =object =args)) =return))))) analyse-jvm-invokevirtual "jvm-invokevirtual" @@ -179,9 +166,7 @@ (return (&/|list (&/V "jvm-class" (&/T $module ?name ?super-class =fields {})))))) (defn analyse-jvm-interface [analyse ?name ?members] - ;; (prn 'analyse-jvm-interface ?name ?members) (|do [=members (&/map% (fn [member] - ;; (prn 'analyse-jvm-interface (&/show-ast member)) (matchv ::M/objects [member] [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ":'"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "->"]]]] @@ -190,15 +175,13 @@ ["lux;Nil" _]]]]]]]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?member-name]]]] ["lux;Nil" _]]]]]]]]]]] - (do ;; (prn 'analyse-jvm-interface ?member-name ?inputs ?output) - (|do [inputs* (&/map% extract-ident ?inputs)] - (return [?member-name [inputs* ?output]]))) + (|do [inputs* (&/map% extract-ident ?inputs)] + (return [?member-name [inputs* ?output]])) [_] (fail "[Analyser Error] Invalid method signature!"))) ?members) - :let [;; _ (prn '=members =members) - =methods (into {} (for [[method [inputs output]] (&/->seq =members)] + :let [=methods (into {} (for [[method [inputs output]] (&/->seq =members)] [method {:access :public :type [inputs output]}]))] $module &/get-module-name] @@ -270,11 +253,7 @@ ) (defn analyse-jvm-program [analyse ?args ?body] - (|do [;; =body (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text)) - ;; (&&/analyse-1 analyse ?body)) - =body (&/with-scope "" + (|do [=body (&/with-scope "" (&&env/with-local "" (&/V "lux;AppT" (&/T &type/List &type/Text)) - (analyse-1+ analyse ?body))) - ;; =body (analyse-1+ analyse ?body) - ] + (analyse-1+ analyse ?body)))] (return (&/|list (&/V "jvm-program" =body))))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 859f47e56..4dd1be38f 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -8,8 +8,6 @@ ;; [Resource] (defn with-lambda [self self-type arg arg-type body] - ;; (prn 'with-lambda (&/|length self) (&/|length arg)) - ;; (prn 'with-lambda [(aget self 0) (aget self 1)] [(aget arg 0) (aget arg 1)] (alength self) (alength arg)) (|let [[?module1 ?name1] self [?module2 ?name2] arg] (&/with-closure @@ -21,11 +19,6 @@ (return (&/T scope-name =captured =return))))))))) (defn close-over [scope ident register frame] - ;; (prn 'close-over - ;; (&host/location scope) - ;; (&host/location (&/|list ident)) - ;; register - ;; (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER))) (matchv ::M/objects [register] [[_ register-type]] (|let [register* (&/T (&/V "captured" (&/T scope diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 2a68e0aeb..d461d5b6b 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -15,7 +15,6 @@ (defn ^:private analyse-1+ [analyse ?token] (&type/with-var (fn [$var] - ;; (prn 'analyse-1+ (aget $var 1) (&/show-ast ?token)) (|do [=expr (&&/analyse-1 analyse $var ?token)] (matchv ::M/objects [=expr] [[?item ?type]] @@ -25,9 +24,6 @@ ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] - ;; (prn "^^ analyse-tuple ^^") - ;; (prn 'analyse-tuple (str "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]") - ;; (&type/show-type exo-type)) (|do [exo-type* (&type/actual-type exo-type)] (matchv ::M/objects [exo-type*] [["lux;TupleT" ?members]] @@ -48,9 +44,7 @@ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) (defn analyse-variant [analyse exo-type ident ?value] - ;; (prn "^^ analyse-variant ^^") - (|do [;; :let [_ (prn 'analyse-variant/exo-type (&type/show-type exo-type))] - exo-type* (matchv ::M/objects [exo-type] + (|do [exo-type* (matchv ::M/objects [exo-type] [["lux;VarT" ?id]] (&/try-all% (&/|list (|do [exo-type* (&/try-all% (&/|list (&type/deref ?id) (fail "##8##")))] @@ -59,17 +53,12 @@ (&type/actual-type &type/Type)))) [_] - (&type/actual-type exo-type)) - ;; :let [_ (prn 'analyse-variant/exo-type* (&type/show-type exo-type*))] - ] + (&type/actual-type exo-type))] (matchv ::M/objects [exo-type*] [["lux;VariantT" ?cases]] (|do [?tag (&&/resolved-ident ident)] (if-let [vtype (&/|get ?tag ?cases)] - (|do [;; :let [_ (prn 'VARIANT_BODY ?tag (&/show-ast ?value) (&type/show-type vtype))] - =value (&&/analyse-1 analyse vtype ?value) - ;; :let [_ (prn 'GOT_VALUE =value)] - ] + (|do [=value (&&/analyse-1 analyse vtype ?value)] (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*))))) @@ -105,7 +94,6 @@ slot-type (if-let [slot-type (&/|get ?tag types)] (return slot-type) (fail (str "[Analyser Error] Record type does not have slot: " ?tag))) - ;; :let [_ (prn 'slot ?tag (&/show-ast ?value) (&type/show-type slot-type))] =value (&&/analyse-1 analyse slot-type ?value)] (return (&/T ?tag =value))) @@ -118,101 +106,77 @@ (|do [module-name &/get-module-name] (fn [state] (|let [[?module ?name] ident - ;; _ (prn 'analyse-symbol ?module ?name) local-ident (str ?module ";" ?name) stack (&/get$ &/$ENVS state) no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not) (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not)) [inner outer] (&/|split-with no-binding? stack)] - (do ;; (when (= "<" ?name) - ;; (prn 'HALLO (&/|length inner) (&/|length outer))) - (matchv ::M/objects [outer] - [["lux;Nil" _]] - (&/run-state (|do [[[r-module r-name] $def] (&&module/find-def (if (= "" ?module) module-name ?module) - ?name) - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - ;; :let [_ (println "Got endo-type:" endo-type)] - _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) - (do ;; (println "OH YEAH" (if (= "" ?module) module-name ?module) - ;; ?name) - (return nil)) - (&type/check exo-type endo-type)) - ;; :let [_ (println "Type-checked:" exo-type endo-type)] - ] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) - - [["lux;Cons" [?genv ["lux;Nil" _]]]] - (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] - (do (when (= "<" ?name) - (prn 'GOT_GLOBAL local-ident)) - (matchv ::M/objects [global] - [[["lux;Global" [?module* ?name*]] _]] - (&/run-state (|do [;; :let [_ (prn 'GLOBAL/_1 ?module* ?name*)] - ;; :let [_ (when (= "<" ?name) - ;; (println "Pre Found def:" ?module* ?name*))] - [[r-module r-name] $def] (&&module/find-def ?module* ?name*) - ;; :let [_ (prn 'GLOBAL/_2 r-module r-name)] - ;; :let [_ (when (= "<" ?name) - ;; (println "Found def:" r-module r-name))] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - ;; :let [_ (println "Got endo-type:" endo-type)] - _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) - (do ;; (println "OH YEAH" ?module* ?name*) - (return nil)) - (&type/check exo-type endo-type)) - ;; :let [_ (println "Type-checked:" exo-type endo-type)] - ;; :let [_ (when (= "<" ?name) - ;; (println "Returnin'"))] - ] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) - - [_] - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))) - (fail* "")) - - [["lux;Cons" [top-outer _]]] - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) - (&/|map #(&/get$ &/$NAME %) outer) - (&/|reverse inner))) - [=local inner*] (&/fold (fn [register+new-inner frame+in-scope] - (|let [[register new-inner] register+new-inner - [frame in-scope] frame+in-scope - [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ident register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) - (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) - (&/|list)) - (&/zip2 (&/|reverse inner) scopes))] - (&/run-state (|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] - (return (&/|list =local))) - (&/set$ &/$ENVS (&/|++ inner* outer) state))) - )))) + (matchv ::M/objects [outer] + [["lux;Nil" _]] + (&/run-state (|do [[[r-module r-name] $def] (&&module/find-def (if (= "" ?module) module-name ?module) + ?name) + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" ?type]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state) + + [["lux;Cons" [?genv ["lux;Nil" _]]]] + (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] + (matchv ::M/objects [global] + [[["lux;Global" [?module* ?name*]] _]] + (&/run-state (|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" ?type]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state) + + [_] + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")) + (fail* "")) + + [["lux;Cons" [top-outer _]]] + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) + (&/|map #(&/get$ &/$NAME %) outer) + (&/|reverse inner))) + [=local inner*] (&/fold (fn [register+new-inner frame+in-scope] + (|let [[register new-inner] register+new-inner + [frame in-scope] frame+in-scope + [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ident register frame)] + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) + (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) + (&/|list)) + (&/zip2 (&/|reverse inner) scopes))] + (&/run-state (|do [btype (&&/expr-type =local) + _ (&type/check exo-type btype)] + (return (&/|list =local))) + (&/set$ &/$ENVS (&/|++ inner* outer) state))) + ))) )) (defn ^:private analyse-apply* [analyse exo-type =fn ?args] - ;; (prn 'analyse-apply* (&/->seq (&/|map &/show-ast ?args))) - ;; (prn 'analyse-apply*/exo-type (&type/show-type exo-type)) (matchv ::M/objects [=fn] [[?fun-expr ?fun-type]] (matchv ::M/objects [?args] @@ -230,11 +194,6 @@ output (analyse-apply* analyse exo-type (&/T ?fun-expr type*) ?args)] (matchv ::M/objects [output $var] [[?expr* ?type*] ["lux;VarT" ?id]] - ;; (|do [? (&type/bound? ?id)] - ;; (if ? - ;; (return (&/T ?expr* ?type*)) - ;; (|do [type** (&type/clean $var ?type*)] - ;; (return (&/T ?expr* type**))))) (|do [? (&type/bound? ?id) _ (if ? (return nil) @@ -245,9 +204,6 @@ )))) [["lux;LambdaT" [?input-t ?output-t]]] - ;; (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)] - ;; (return (&/T (&/V "apply" (&/T =fn =arg)) - ;; ?output-t))) (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)] (analyse-apply* analyse exo-type (&/T (&/V "apply" (&/T =fn =arg)) ?output-t) @@ -258,58 +214,37 @@ ))) (defn analyse-apply [analyse exo-type =fn ?args] - ;; (prn 'analyse-apply1 (aget =fn 0)) (|do [loader &/loader] (matchv ::M/objects [=fn] [[=fn-form =fn-type]] - (do ;; (prn 'analyse-apply2 (aget =fn-form 0)) - (matchv ::M/objects [=fn-form] - [["lux;Global" [?module ?name]]] - (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name) - ;; :let [_ (prn 'apply [?module ?name] (aget $def 0))] - ] - (matchv ::M/objects [$def] - [["lux;MacroD" macro]] - (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) - ;; :let [_ (cond (= ?name "using") - ;; (println (str "using: " (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) - - ;; ;; (= ?name "def") - ;; ;; (println (str "def " ?module ";" ?name ": " (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) - - ;; ;; (= ?name "type`") - ;; ;; (println (str "type`: " (->> macro-expansion (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) - - ;; :else - ;; nil)] - ] - (&/flat-map% (partial analyse exo-type) macro-expansion)) + (matchv ::M/objects [=fn-form] + [["lux;Global" [?module ?name]]] + (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] + (matchv ::M/objects [$def] + [["lux;MacroD" macro]] + (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))] + (&/flat-map% (partial analyse exo-type) macro-expansion)) - [_] - (|do [output (analyse-apply* analyse exo-type =fn ?args)] - (return (&/|list output))))) - [_] (|do [output (analyse-apply* analyse exo-type =fn ?args)] (return (&/|list output))))) + + [_] + (|do [output (analyse-apply* analyse exo-type =fn ?args)] + (return (&/|list output)))) ))) (defn analyse-case [analyse exo-type ?value ?branches] - ;; (prn 'analyse-case 'exo-type (&type/show-type exo-type) (&/show-ast ?value)) (|do [:let [num-branches (&/|length ?branches)] _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.") _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.") =value (analyse-1+ analyse ?value) =value-type (&&/expr-type =value) - ;; :let [_ (prn 'analyse-case/GOT_VALUE (&type/show-type =value-type))] - =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches)) - ;; :let [_ (prn 'analyse-case/GOT_MATCH)] - ] + =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] (return (&/|list (&/T (&/V "case" (&/T =value =match)) exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] - ;; (prn 'analyse-lambda ?self ?arg ?body) (matchv ::M/objects [exo-type] [["lux;LambdaT" [?arg-t ?return-t]]] (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type @@ -319,13 +254,9 @@ [_] (fail (str "[Analyser Error] Functions require function types: " - ;; (str (aget ?self 0) ";" (aget ?self 1)) - ;; (str( aget ?arg 0) ";" (aget ?arg 1)) - ;; (&/show-ast ?body) (&type/show-type exo-type))))) (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] - ;; (prn 'analyse-lambda**/&& (aget exo-type 0)) (matchv ::M/objects [exo-type] [["lux;AllT" [_env _self _arg _body]]] (&type/with-var @@ -351,44 +282,19 @@ (analyse-lambda* analyse exo-type* ?self ?arg ?body)) )) -;; (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] -;; ;; (prn 'analyse-lambda**/&& (aget exo-type 0)) -;; (matchv ::M/objects [exo-type] -;; [["lux;AllT" [_env _self _arg _body]]] -;; (&type/with-var -;; (fn [$var] -;; (|do [exo-type* (&type/apply-type exo-type $var) -;; output (analyse-lambda** analyse exo-type* ?self ?arg ?body)] -;; (matchv ::M/objects [$var] -;; [["lux;VarT" ?id]] -;; (|do [? (&type/bound? ?id)] -;; (if ? -;; (|do [dtype (&type/deref ?id)] -;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype)))) -;; (return output))))))) - -;; [_] -;; (|do [exo-type* (&type/actual-type exo-type)] -;; (analyse-lambda* analyse exo-type* ?self ?arg ?body)) -;; )) - (defn analyse-lambda [analyse exo-type ?self ?arg ?body] (|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)] (return (&/|list output)))) (defn analyse-def [analyse ?name ?value] - ;; (prn 'analyse-def/CODE ?name (&/show-ast ?value)) (prn 'analyse-def/BEGIN ?name) (|do [module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? (fail (str "[Analyser Error] Can't redefine " ?name)) - (|do [;; :let [_ (prn 'analyse-def/_0)] - =value (&/with-scope ?name + (|do [=value (&/with-scope ?name (analyse-1+ analyse ?value)) - =value-type (&&/expr-type =value) - ;; :let [_ (prn 'analyse-def/_1 [?name ?value] (aget =value 0 0))] - ] + =value-type (&&/expr-type =value)] (matchv ::M/objects [=value] [[["lux;Global" [?r-module ?r-name]] _]] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) @@ -409,11 +315,6 @@ (return (&/|list (&/V "def" (&/T ?name =value def-data)))))) )))) -(defn analyse-declare-macro [analyse ?name] - (|do [module-name &/get-module-name - _ (&&module/declare-macro module-name ?name)] - (return (&/|list)))) - (defn analyse-declare-macro [analyse ?name] (|do [module-name &/get-module-name] (return (&/|list (&/V "declare-macro" (&/T module-name ?name)))))) @@ -427,16 +328,10 @@ (return (&/|list)))) (defn analyse-check [analyse eval! exo-type ?type ?value] - ;; (println "analyse-check#0") (|do [=type (&&/analyse-1 analyse &type/Type ?type) - ;; =type (analyse-1+ analyse ?type) - ;; :let [_ (println "analyse-check#1")] ==type (eval! =type) _ (&type/check exo-type ==type) - ;; :let [_ (println "analyse-check#4" (&type/show-type ==type))] - =value (&&/analyse-1 analyse ==type ?value) - ;; :let [_ (println "analyse-check#5")] - ] + =value (&&/analyse-1 analyse ==type ?value)] (matchv ::M/objects [=value] [[?expr ?expr-type]] (return (&/|list (&/T ?expr ==type)))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index de68f48aa..5960d3080 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -32,7 +32,6 @@ (defn def-alias [a-module a-name r-module r-name type] (fn [state] - ;; (prn 'def-alias [a-module a-name] '=> [r-module r-name]) (matchv ::M/objects [(&/get$ &/$ENVS state)] [["lux;Cons" [?env ["lux;Nil" _]]]] (return* (->> state @@ -53,7 +52,6 @@ (defn exists? [name] (fn [state] - ;; (prn `exists? name (->> state (&/get$ &/$MODULES) (&/|contains? name))) (return* state (->> state (&/get$ &/$MODULES) (&/|contains? name))))) @@ -96,20 +94,19 @@ (if-let [$def (&/|get name $module)] (matchv ::M/objects [$def] [[exported? ["lux;ValueD" ?type]]] - (do ;; (prn 'declare-macro/?type (aget ?type 0)) - (&/run-state (|do [_ (&type/check &type/Macro ?type) - ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (&host/location (&/|list module name))) - (.getField "_datum") - (.get nil))]] - (fn [state*] - (return* (&/update$ &/$MODULES - (fn [$modules] - (&/|put module (&/|put name (&/T exported? (&/V "lux;MacroD" macro)) $module) - $modules)) - state*) - nil))) - state)) + (&/run-state (|do [_ (&type/check &type/Macro ?type) + ^ClassLoader loader &/loader + :let [macro (-> (.loadClass loader (&host/location (&/|list module name))) + (.getField "_datum") + (.get nil))]] + (fn [state*] + (return* (&/update$ &/$MODULES + (fn [$modules] + (&/|put module (&/|put name (&/T exported? (&/V "lux;MacroD" macro)) $module) + $modules)) + state*) + nil))) + state) [[_ ["lux;MacroD" _]]] (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 70a658d19..283d06f52 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -81,7 +81,6 @@ (reverse (partition 2 elems)))) (defn |get [slot table] - ;; (prn '|get slot (aget table 0)) (matchv ::M/objects [table] [["lux;Nil" _]] nil @@ -112,7 +111,6 @@ (V "lux;Cons" (T (T k v) (|remove slot table*)))))) (defn |merge [table1 table2] - ;; (prn '|merge (aget table1 0) (aget table2 0)) (matchv ::M/objects [table2] [["lux;Nil" _]] table1 @@ -149,7 +147,6 @@ ;; [Resources/Monads] (defn fail [message] (fn [_] - ;; (prn 'FAIL message) (V "lux;Left" message))) (defn return [value] @@ -178,10 +175,7 @@ (fn [val#] (matchv ::M/objects [val#] [~label] - ~inner))) - ;; `(bind ~computation - ;; (fn [~label] ~inner)) - )) + ~inner))))) return (reverse (partition 2 steps)))) @@ -199,7 +193,6 @@ (V "lux;Cons" (T head tail))) (defn |++ [xs ys] - ;; (prn '|++ (and xs (aget xs 0)) (and ys (aget ys 0))) (matchv ::M/objects [xs] [["lux;Nil" _]] ys @@ -208,7 +201,6 @@ (V "lux;Cons" (T x (|++ xs* ys))))) (defn |map [f xs] - ;; (prn '|map (aget xs 0)) (matchv ::M/objects [xs] [["lux;Nil" _]] xs @@ -288,7 +280,6 @@ (|cons init (folds f (f init x) xs*)))) (defn |length [xs] - ;; (prn '|length (aget xs 0)) (fold (fn [acc _] (inc acc)) 0 xs)) (let [|range* (fn |range* [from to] @@ -343,16 +334,13 @@ (do-template [ ] (defn [f xs] - ;; (prn ' 0 (aget xs 0)) (matchv ::M/objects [xs] [["lux;Nil" _]] (return xs) [["lux;Cons" [x xs*]]] (|do [y (f x) - ;; :let [_ (prn ' 1 (class y)) - ;; _ (prn ' 2 (aget y 0))] - ys ( f xs*)] + ys ( f xs*)] (return ( y ys))))) map% |cons @@ -373,7 +361,6 @@ xs)) (defn show-table [table] - ;; (prn 'show-table (aget table 0)) (str "{{" (->> table (|map (fn [kv] (|let [[k v] kv] (str k " = ???")))) @@ -383,9 +370,7 @@ (defn apply% [monad call-state] (fn [state] - ;; (prn 'apply-m monad call-state) (let [output (monad call-state)] - ;; (prn 'apply-m/output output) (matchv ::M/objects [output] [["lux;Right" [?state ?datum]]] (return* state ?datum) @@ -469,12 +454,6 @@ (return nil) (fail msg))) state) - ;; (if (= "[Reader Error] EOF" msg) - ;; ((|do [? source-consumed? - ;; :let [_ (prn '? ?)]] - ;; (return nil)) - ;; state) - ;; (fail* msg)) ))) (defn ^:private normalize-char [char] @@ -569,8 +548,6 @@ (def get-writer (fn [state] (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] - ;; (prn 'get-writer (class writer*)) - ;; (prn 'get-writer (aget writer* 0)) (matchv ::M/objects [writer*] [["lux;Some" datum]] (return* state datum) @@ -656,16 +633,6 @@ output)))) (defn show-ast [ast] - ;; (prn 'show-ast (aget ast 0)) - ;; (prn 'show-ast (aget ast 1 1 0)) - ;; (cond (= "lux;Meta" (aget ast 1 1 0)) - ;; (prn 'EXTRA 'show-ast (aget ast 1 1 1 1 0)) - - ;; (= "lux;Symbol" (aget ast 1 1 0)) - ;; (prn 'EXTRA 'show-ast (aget ast 1 1 1 1)) - - ;; :else - ;; nil) (matchv ::M/objects [ast] [["lux;Meta" [_ ["lux;Bool" ?value]]]] (pr-str ?value) @@ -707,3 +674,40 @@ (defn ident->text [ident] (|let [[?module ?name] ident] (str ?module ";" ?name))) + +(defn map2% [f xs ys] + (matchv ::M/objects [xs ys] + [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|do [z (f x y) + zs (map2% f xs* ys*)] + (return (|cons z zs))) + + [["lux;Nil" _] ["lux;Nil" _]] + (return (V "lux;Nil" nil)) + + [_ _] + (fail "Lists don't match in size."))) + +(defn fold2% [f init xs ys] + (matchv ::M/objects [xs ys] + [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|do [init* (f init x y)] + (fold2% f init* xs* ys*)) + + [["lux;Nil" _] ["lux;Nil" _]] + (return init) + + [_ _] + (fail "Lists don't match in size."))) + +(defn fold2 [f init xs ys] + (matchv ::M/objects [xs ys] + [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (and init + (fold2 f (f init x y) xs* ys*)) + + [["lux;Nil" _] ["lux;Nil" _]] + init + + [_ _] + false)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 5a9f1b39d..f970540c9 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -19,9 +19,7 @@ [lux :as &&lux] [host :as &&host] [case :as &&case] - [lambda :as &&lambda]) - ;; :reload - ) + [lambda :as &&lambda])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -29,280 +27,277 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] - ;; (prn 'compile-expression (aget syntax 0)) (matchv ::M/objects [syntax] [[?form ?type]] - (do ;; (prn 'compile-expression2 (aget ?form 0)) - (matchv ::M/objects [?form] - [["bool" ?value]] - (&&lux/compile-bool compile-expression ?type ?value) - - [["int" ?value]] - (&&lux/compile-int compile-expression ?type ?value) - - [["real" ?value]] - (&&lux/compile-real compile-expression ?type ?value) - - [["char" ?value]] - (&&lux/compile-char compile-expression ?type ?value) - - [["text" ?value]] - (&&lux/compile-text compile-expression ?type ?value) - - [["tuple" ?elems]] - (&&lux/compile-tuple compile-expression ?type ?elems) - - [["record" ?elems]] - (&&lux/compile-record compile-expression ?type ?elems) - - [["lux;Local" ?idx]] - (&&lux/compile-local compile-expression ?type ?idx) - - [["captured" [?scope ?captured-id ?source]]] - (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - - [["lux;Global" [?owner-class ?name]]] - (&&lux/compile-global compile-expression ?type ?owner-class ?name) - - [["apply" [?fn ?arg]]] - (&&lux/compile-apply compile-expression ?type ?fn ?arg) - - [["variant" [?tag ?members]]] - (&&lux/compile-variant compile-expression ?type ?tag ?members) - - [["case" [?value ?match]]] - (&&case/compile-case compile-expression ?type ?value ?match) - - [["lambda" [?scope ?env ?body]]] - (&&lambda/compile-lambda compile-expression ?scope ?env ?body) - - ;; Integer arithmetic - [["jvm-iadd" [?x ?y]]] - (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) - - [["jvm-isub" [?x ?y]]] - (&&host/compile-jvm-isub compile-expression ?type ?x ?y) - - [["jvm-imul" [?x ?y]]] - (&&host/compile-jvm-imul compile-expression ?type ?x ?y) - - [["jvm-idiv" [?x ?y]]] - (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) - - [["jvm-irem" [?x ?y]]] - (&&host/compile-jvm-irem compile-expression ?type ?x ?y) - - [["jvm-ieq" [?x ?y]]] - (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) - - [["jvm-ilt" [?x ?y]]] - (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) - - [["jvm-igt" [?x ?y]]] - (&&host/compile-jvm-igt compile-expression ?type ?x ?y) - - ;; Long arithmetic - [["jvm-ladd" [?x ?y]]] - (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) - - [["jvm-lsub" [?x ?y]]] - (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) - - [["jvm-lmul" [?x ?y]]] - (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) - - [["jvm-ldiv" [?x ?y]]] - (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) - - [["jvm-lrem" [?x ?y]]] - (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) - - [["jvm-leq" [?x ?y]]] - (&&host/compile-jvm-leq compile-expression ?type ?x ?y) - - [["jvm-llt" [?x ?y]]] - (&&host/compile-jvm-llt compile-expression ?type ?x ?y) - - [["jvm-lgt" [?x ?y]]] - (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) - - ;; Float arithmetic - [["jvm-fadd" [?x ?y]]] - (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) - - [["jvm-fsub" [?x ?y]]] - (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) - - [["jvm-fmul" [?x ?y]]] - (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) - - [["jvm-fdiv" [?x ?y]]] - (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) - - [["jvm-frem" [?x ?y]]] - (&&host/compile-jvm-frem compile-expression ?type ?x ?y) - - [["jvm-feq" [?x ?y]]] - (&&host/compile-jvm-feq compile-expression ?type ?x ?y) - - [["jvm-flt" [?x ?y]]] - (&&host/compile-jvm-flt compile-expression ?type ?x ?y) - - [["jvm-fgt" [?x ?y]]] - (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) - - ;; Double arithmetic - [["jvm-dadd" [?x ?y]]] - (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) - - [["jvm-dsub" [?x ?y]]] - (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) - - [["jvm-dmul" [?x ?y]]] - (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) - - [["jvm-ddiv" [?x ?y]]] - (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) - - [["jvm-drem" [?x ?y]]] - (&&host/compile-jvm-drem compile-expression ?type ?x ?y) - - [["jvm-deq" [?x ?y]]] - (&&host/compile-jvm-deq compile-expression ?type ?x ?y) - - [["jvm-dlt" [?x ?y]]] - (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) - - [["jvm-dgt" [?x ?y]]] - (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) - - [["jvm-null" _]] - (&&host/compile-jvm-null compile-expression ?type) - - [["jvm-null?" ?object]] - (&&host/compile-jvm-null? compile-expression ?type ?object) - - [["jvm-new" [?class ?classes ?args]]] - (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) - - [["jvm-getstatic" [?class ?field]]] - (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) - - [["jvm-getfield" [?class ?field ?object]]] - (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) - - [["jvm-putstatic" [?class ?field ?value]]] - (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) - - [["jvm-putfield" [?class ?field ?object ?value]]] - (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) - - [["jvm-invokestatic" [?class ?method ?classes ?args]]] - (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) - - [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] - (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) - - [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]] - (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) - - [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]] - (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - - [["jvm-new-array" [?class ?length]]] - (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) + (matchv ::M/objects [?form] + [["bool" ?value]] + (&&lux/compile-bool compile-expression ?type ?value) + + [["int" ?value]] + (&&lux/compile-int compile-expression ?type ?value) + + [["real" ?value]] + (&&lux/compile-real compile-expression ?type ?value) + + [["char" ?value]] + (&&lux/compile-char compile-expression ?type ?value) + + [["text" ?value]] + (&&lux/compile-text compile-expression ?type ?value) + + [["tuple" ?elems]] + (&&lux/compile-tuple compile-expression ?type ?elems) + + [["record" ?elems]] + (&&lux/compile-record compile-expression ?type ?elems) + + [["lux;Local" ?idx]] + (&&lux/compile-local compile-expression ?type ?idx) + + [["captured" [?scope ?captured-id ?source]]] + (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) + + [["lux;Global" [?owner-class ?name]]] + (&&lux/compile-global compile-expression ?type ?owner-class ?name) + + [["apply" [?fn ?arg]]] + (&&lux/compile-apply compile-expression ?type ?fn ?arg) + + [["variant" [?tag ?members]]] + (&&lux/compile-variant compile-expression ?type ?tag ?members) + + [["case" [?value ?match]]] + (&&case/compile-case compile-expression ?type ?value ?match) + + [["lambda" [?scope ?env ?body]]] + (&&lambda/compile-lambda compile-expression ?scope ?env ?body) + + ;; Integer arithmetic + [["jvm-iadd" [?x ?y]]] + (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) + + [["jvm-isub" [?x ?y]]] + (&&host/compile-jvm-isub compile-expression ?type ?x ?y) + + [["jvm-imul" [?x ?y]]] + (&&host/compile-jvm-imul compile-expression ?type ?x ?y) + + [["jvm-idiv" [?x ?y]]] + (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) + + [["jvm-irem" [?x ?y]]] + (&&host/compile-jvm-irem compile-expression ?type ?x ?y) + + [["jvm-ieq" [?x ?y]]] + (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) + + [["jvm-ilt" [?x ?y]]] + (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) + + [["jvm-igt" [?x ?y]]] + (&&host/compile-jvm-igt compile-expression ?type ?x ?y) + + ;; Long arithmetic + [["jvm-ladd" [?x ?y]]] + (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) + + [["jvm-lsub" [?x ?y]]] + (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) + + [["jvm-lmul" [?x ?y]]] + (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) + + [["jvm-ldiv" [?x ?y]]] + (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) + + [["jvm-lrem" [?x ?y]]] + (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) + + [["jvm-leq" [?x ?y]]] + (&&host/compile-jvm-leq compile-expression ?type ?x ?y) + + [["jvm-llt" [?x ?y]]] + (&&host/compile-jvm-llt compile-expression ?type ?x ?y) + + [["jvm-lgt" [?x ?y]]] + (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) + + ;; Float arithmetic + [["jvm-fadd" [?x ?y]]] + (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) + + [["jvm-fsub" [?x ?y]]] + (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) + + [["jvm-fmul" [?x ?y]]] + (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) + + [["jvm-fdiv" [?x ?y]]] + (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) + + [["jvm-frem" [?x ?y]]] + (&&host/compile-jvm-frem compile-expression ?type ?x ?y) + + [["jvm-feq" [?x ?y]]] + (&&host/compile-jvm-feq compile-expression ?type ?x ?y) + + [["jvm-flt" [?x ?y]]] + (&&host/compile-jvm-flt compile-expression ?type ?x ?y) + + [["jvm-fgt" [?x ?y]]] + (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) + + ;; Double arithmetic + [["jvm-dadd" [?x ?y]]] + (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) + + [["jvm-dsub" [?x ?y]]] + (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) + + [["jvm-dmul" [?x ?y]]] + (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) + + [["jvm-ddiv" [?x ?y]]] + (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) + + [["jvm-drem" [?x ?y]]] + (&&host/compile-jvm-drem compile-expression ?type ?x ?y) + + [["jvm-deq" [?x ?y]]] + (&&host/compile-jvm-deq compile-expression ?type ?x ?y) + + [["jvm-dlt" [?x ?y]]] + (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) + + [["jvm-dgt" [?x ?y]]] + (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) + + [["jvm-null" _]] + (&&host/compile-jvm-null compile-expression ?type) + + [["jvm-null?" ?object]] + (&&host/compile-jvm-null? compile-expression ?type ?object) + + [["jvm-new" [?class ?classes ?args]]] + (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) + + [["jvm-getstatic" [?class ?field]]] + (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) + + [["jvm-getfield" [?class ?field ?object]]] + (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) + + [["jvm-putstatic" [?class ?field ?value]]] + (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) + + [["jvm-putfield" [?class ?field ?object ?value]]] + (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) + + [["jvm-invokestatic" [?class ?method ?classes ?args]]] + (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) + + [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] + (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) + + [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]] + (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) + + [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]] + (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) + + [["jvm-new-array" [?class ?length]]] + (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) - [["jvm-aastore" [?array ?idx ?elem]]] - (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) + [["jvm-aastore" [?array ?idx ?elem]]] + (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) - [["jvm-aaload" [?array ?idx]]] - (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) + [["jvm-aaload" [?array ?idx]]] + (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) - [["jvm-try" [?body ?catches ?finally]]] - (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) + [["jvm-try" [?body ?catches ?finally]]] + (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) - [["jvm-throw" ?ex]] - (&&host/compile-jvm-throw compile-expression ?type ?ex) + [["jvm-throw" ?ex]] + (&&host/compile-jvm-throw compile-expression ?type ?ex) - [["jvm-monitorenter" ?monitor]] - (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) + [["jvm-monitorenter" ?monitor]] + (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) - [["jvm-monitorexit" ?monitor]] - (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) + [["jvm-monitorexit" ?monitor]] + (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) - [["jvm-d2f" ?value]] - (&&host/compile-jvm-d2f compile-expression ?type ?value) + [["jvm-d2f" ?value]] + (&&host/compile-jvm-d2f compile-expression ?type ?value) - [["jvm-d2i" ?value]] - (&&host/compile-jvm-d2i compile-expression ?type ?value) + [["jvm-d2i" ?value]] + (&&host/compile-jvm-d2i compile-expression ?type ?value) - [["jvm-d2l" ?value]] - (&&host/compile-jvm-d2l compile-expression ?type ?value) - - [["jvm-f2d" ?value]] - (&&host/compile-jvm-f2d compile-expression ?type ?value) + [["jvm-d2l" ?value]] + (&&host/compile-jvm-d2l compile-expression ?type ?value) + + [["jvm-f2d" ?value]] + (&&host/compile-jvm-f2d compile-expression ?type ?value) - [["jvm-f2i" ?value]] - (&&host/compile-jvm-f2i compile-expression ?type ?value) + [["jvm-f2i" ?value]] + (&&host/compile-jvm-f2i compile-expression ?type ?value) - [["jvm-f2l" ?value]] - (&&host/compile-jvm-f2l compile-expression ?type ?value) - - [["jvm-i2b" ?value]] - (&&host/compile-jvm-i2b compile-expression ?type ?value) + [["jvm-f2l" ?value]] + (&&host/compile-jvm-f2l compile-expression ?type ?value) + + [["jvm-i2b" ?value]] + (&&host/compile-jvm-i2b compile-expression ?type ?value) - [["jvm-i2c" ?value]] - (&&host/compile-jvm-i2c compile-expression ?type ?value) + [["jvm-i2c" ?value]] + (&&host/compile-jvm-i2c compile-expression ?type ?value) - [["jvm-i2d" ?value]] - (&&host/compile-jvm-i2d compile-expression ?type ?value) + [["jvm-i2d" ?value]] + (&&host/compile-jvm-i2d compile-expression ?type ?value) - [["jvm-i2f" ?value]] - (&&host/compile-jvm-i2f compile-expression ?type ?value) + [["jvm-i2f" ?value]] + (&&host/compile-jvm-i2f compile-expression ?type ?value) - [["jvm-i2l" ?value]] - (&&host/compile-jvm-i2l compile-expression ?type ?value) + [["jvm-i2l" ?value]] + (&&host/compile-jvm-i2l compile-expression ?type ?value) - [["jvm-i2s" ?value]] - (&&host/compile-jvm-i2s compile-expression ?type ?value) + [["jvm-i2s" ?value]] + (&&host/compile-jvm-i2s compile-expression ?type ?value) - [["jvm-l2d" ?value]] - (&&host/compile-jvm-l2d compile-expression ?type ?value) + [["jvm-l2d" ?value]] + (&&host/compile-jvm-l2d compile-expression ?type ?value) - [["jvm-l2f" ?value]] - (&&host/compile-jvm-l2f compile-expression ?type ?value) + [["jvm-l2f" ?value]] + (&&host/compile-jvm-l2f compile-expression ?type ?value) - [["jvm-l2i" ?value]] - (&&host/compile-jvm-l2i compile-expression ?type ?value) + [["jvm-l2i" ?value]] + (&&host/compile-jvm-l2i compile-expression ?type ?value) - [["jvm-iand" [?x ?y]]] - (&&host/compile-jvm-iand compile-expression ?type ?x ?y) + [["jvm-iand" [?x ?y]]] + (&&host/compile-jvm-iand compile-expression ?type ?x ?y) - [["jvm-ior" [?x ?y]]] - (&&host/compile-jvm-ior compile-expression ?type ?x ?y) + [["jvm-ior" [?x ?y]]] + (&&host/compile-jvm-ior compile-expression ?type ?x ?y) - [["jvm-land" [?x ?y]]] - (&&host/compile-jvm-land compile-expression ?type ?x ?y) + [["jvm-land" [?x ?y]]] + (&&host/compile-jvm-land compile-expression ?type ?x ?y) - [["jvm-lor" [?x ?y]]] - (&&host/compile-jvm-lor compile-expression ?type ?x ?y) + [["jvm-lor" [?x ?y]]] + (&&host/compile-jvm-lor compile-expression ?type ?x ?y) - [["jvm-lxor" [?x ?y]]] - (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) + [["jvm-lxor" [?x ?y]]] + (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) - [["jvm-lshl" [?x ?y]]] - (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) + [["jvm-lshl" [?x ?y]]] + (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) - [["jvm-lshr" [?x ?y]]] - (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) + [["jvm-lshr" [?x ?y]]] + (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) - [["jvm-lushr" [?x ?y]]] - (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) - )) + [["jvm-lushr" [?x ?y]]] + (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) + ) )) (defn ^:private compile-statement [syntax] - ;; (prn 'compile-statement syntax) (matchv ::M/objects [syntax] [["def" [?name ?body ?def-data]]] (&&lux/compile-def compile-expression ?name ?body ?def-data) @@ -320,8 +315,6 @@ (&&host/compile-jvm-class compile-expression ?package ?name ?super-class ?fields ?methods))) (defn ^:private eval! [expr] - ;; (prn 'eval! (aget expr 0)) - ;; (assert false) (|do [eval-ctor &/get-eval-ctor :let [class-name (str eval-ctor) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) @@ -348,17 +341,10 @@ (.get nil) return))) -(let [compiler-step (|do [analysis+ (&optimizer/optimize eval!) - ;; :let [_ (prn 'analysis+ analysis+)] - ] - (&/map% compile-statement analysis+) - ;; (if (&/|empty? analysis+) - ;; (fail "[Compiler Error] No more to compile.") - ;; (&/map% compile-statement analysis+)) - )] +(let [compiler-step (|do [analysis+ (&optimizer/optimize eval!)] + (&/map% compile-statement analysis+))] (defn ^:private compile-module [name] (fn [state] - (prn 'compile-module name (->> state (&/get$ &/$MODULES) &/|keys &/->seq)) (if (->> state (&/get$ &/$MODULES) (&/|contains? name)) (if (= name "lux") (return* state nil) @@ -373,8 +359,6 @@ (&/update$ &/$MODULES #(&/|put name &a-module/init-module %))))] [["lux;Right" [?state _]]] (do (.visitEnd =class) - ;; (prn 'compile-module 'DONE name) - ;; (prn 'compile-module/?vals ?vals) (&/run-state (&&/save-class! name (.toByteArray =class)) ?state)) [["lux;Left" ?message]] diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index dd7e0ae13..c0a54ba53 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -32,104 +32,102 @@ (return nil))) (defn total-locals [expr] - ;; (prn 'total-locals1 (aget expr 0)) (matchv ::M/objects [expr] [[?struct ?type]] - (do ;; (prn 'total-locals2 (aget ?struct 0)) - (matchv ::M/objects [?struct] - [["case" [?variant ?base-register ?num-registers ?branches]]] - (+ ?num-registers (&/fold max 0 (&/|map (comp total-locals second) ?branches))) - - [["tuple" ?members]] - (&/fold max 0 (&/|map total-locals ?members)) + (matchv ::M/objects [?struct] + [["case" [?variant ?base-register ?num-registers ?branches]]] + (+ ?num-registers (&/fold max 0 (&/|map (comp total-locals second) ?branches))) + + [["tuple" ?members]] + (&/fold max 0 (&/|map total-locals ?members)) - [["variant" [?tag ?value]]] - (total-locals ?value) + [["variant" [?tag ?value]]] + (total-locals ?value) - [["call" [?fn ?args]]] - (&/fold max 0 (&/|map total-locals (&/|cons ?fn ?args))) - - [["jvm-iadd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-isub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-imul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-idiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-irem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-ladd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-lsub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-lmul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-ldiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-lrem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fadd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fsub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fmul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fdiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-frem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-dadd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-dsub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-dmul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-ddiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-drem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + [["call" [?fn ?args]]] + (&/fold max 0 (&/|map total-locals (&/|cons ?fn ?args))) + + [["jvm-iadd" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-isub" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-imul" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-idiv" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-irem" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-ladd" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-lsub" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-lmul" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-ldiv" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-lrem" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-fadd" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-fsub" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-fmul" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-fdiv" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-frem" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-dadd" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-dsub" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-dmul" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-ddiv" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) + + [["jvm-drem" [?x ?y]]] + (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - [["|do" ?exprs]] - (&/fold max 0 (&/|map total-locals ?exprs)) + [["|do" ?exprs]] + (&/fold max 0 (&/|map total-locals ?exprs)) - [["jvm-new" [?class ?classes ?args]]] - (&/fold max 0 (&/|map total-locals ?args)) + [["jvm-new" [?class ?classes ?args]]] + (&/fold max 0 (&/|map total-locals ?args)) - [["jvm-invokestatic" [?class ?method ?classes ?args]]] - (&/fold max 0 (&/|map total-locals ?args)) + [["jvm-invokestatic" [?class ?method ?classes ?args]]] + (&/fold max 0 (&/|map total-locals ?args)) - [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] - (&/fold max 0 (&/|map total-locals ?args)) + [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] + (&/fold max 0 (&/|map total-locals ?args)) - [["jvm-aastore" [?array ?idx ?elem]]] - (&/fold max 0 (&/|map total-locals (&/|list ?array ?elem))) + [["jvm-aastore" [?array ?idx ?elem]]] + (&/fold max 0 (&/|map total-locals (&/|list ?array ?elem))) - [["jvm-aaload" [?array ?idx]]] - (total-locals ?array) + [["jvm-aaload" [?array ?idx]]] + (total-locals ?array) - ;; [["lambda" _]] - ;; 0 - - [_] - 0 - )))) + ;; [["lambda" _]] + ;; 0 + + [_] + 0 + ))) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 738d6bc35..2720e31f7 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -21,7 +21,6 @@ +equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z") compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private compile-match [^MethodVisitor writer ?match $target $else] - ;; (prn 'compile-match (aget ?match 0) $target $else) (matchv ::M/objects [?match] [["StoreTestAC" ?idx]] (doto writer @@ -143,7 +142,6 @@ ))) (defn ^:private separate-bodies [patterns] - ;; (prn 'separate-bodies (aget matches 0)) (|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body] (|let [[$id mappings =matches] $id+mappings+=matches [pattern body] pattern+body] @@ -154,7 +152,6 @@ (let [ex-class (&host/->class "java.lang.IllegalStateException")] (defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end] - ;; (prn 'compile-pattern-matching ?matches $end) (let [entries (&/|map (fn [?branch+?body] (|let [[?branch ?body] ?branch+?body label (new Label)] @@ -167,10 +164,7 @@ (.visitLabel $else)) (->> (|let [[?body ?match] ?body+?match]) (doseq [?body+?match (&/->seq patterns) - :let [;; _ (prn 'compile-pattern-matching/pattern pattern) - ;; _ (prn '?body+?match (alength ?body+?match) (aget ?body+?match 0)) - ;; _ (prn '?body+?match (aget ?body+?match 0)) - $else (new Label)]]))) + :let [$else (new Label)]]))) (.visitInsn Opcodes/POP) (.visitTypeInsn Opcodes/NEW ex-class) (.visitInsn Opcodes/DUP) @@ -187,7 +181,6 @@ ;; [Resources] (defn compile-case [compile *type* ?value ?matches] - ;; (prn 'compile-case ?value ?matches) (|do [^MethodVisitor *writer* &/get-writer :let [$end (new Label)] _ (compile ?value) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 71d3ced53..429424240 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -198,7 +198,6 @@ (do-template [ ] (defn [compile *type* ?class ?method ?classes ?object ?args] - ;; (prn 'compile-jvm-invokevirtual ?classes *type*) (|do [^MethodVisitor *writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] _ (compile ?object) @@ -327,7 +326,6 @@ (&&/save-class! full-name (.toByteArray =class)))) (defn compile-jvm-interface [compile ?package ?name ?methods] - ;; (prn 'compile-jvm-interface ?package ?name ?methods) (let [parent-dir (&host/->package ?package) full-name (str parent-dir "/" ?name) =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) @@ -335,13 +333,10 @@ full-name nil "java/lang/Object" nil)) _ (do (doseq [[?method ?props] ?methods :let [[?args ?return] (:type ?props) - signature (str "(" (&/fold str "" (&/|map &host/->type-signature ?args)) ")" (&host/->type-signature ?return)) - ;; _ (prn 'signature signature) - ]] + signature (str "(" (&/fold str "" (&/|map &host/->type-signature ?args)) ")" (&host/->type-signature ?return))]] (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil)) (.visitEnd =interface) (.mkdirs (java.io.File. (str "output/" parent-dir))))] - ;; (prn 'SAVED_CLASS full-name) (&&/save-class! full-name (.toByteArray =interface)))) (defn compile-jvm-try [compile *type* ?body ?catches ?finally] diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 962a32ab6..3ba6e52f1 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -11,9 +11,7 @@ [analyser :as &analyser] [host :as &host]) [lux.analyser.base :as &a] - (lux.compiler [base :as &&]) - ;; :reload - ) + (lux.compiler [base :as &&])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -39,9 +37,7 @@ (-> (doto (.visitVarInsn Opcodes/ALOAD 0) (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id) - ;; _ (prn 'add-lambda- class-name ?captured-id) - ]) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (matchv ::M/objects [?name+?captured] [[?name [["captured" [_ ?captured-id ?source]] _]]]) (doseq [?name+?captured (&/->seq env)]))) @@ -79,7 +75,6 @@ (return ret)))) (defn ^:private instance-closure [compile lambda-class closed-over init-signature] - ;; (prn 'instance-closure lambda-class (&/|length closed-over) init-signature) (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW lambda-class) @@ -100,7 +95,6 @@ ;; [Exports] (defn compile-lambda [compile ?scope ?env ?body] - ;; (prn 'compile-lambda ?scope (&host/location ?scope) ?env) (|do [:let [lambda-class (&host/location ?scope) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) @@ -110,17 +104,11 @@ (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (matchv ::M/objects [?name+?captured] [[?name [["captured" [_ ?captured-id ?source]] _]]]) - (doseq [?name+?captured (&/->seq ?env) - ;; :let [_ (prn '?name+?captured (alength ?name+?captured)) - ;; _ (prn '?name+?captured (aget ?name+?captured 1 0)) - ;; _ (prn '?name+?captured (aget ?name+?captured 1 1 0 0))] - ]))) + (doseq [?name+?captured (&/->seq ?env)]))) (add-lambda-apply lambda-class ?env) (add-lambda- lambda-class ?env) )] _ (add-lambda-impl =class compile lambda-impl-signature ?body) - :let [_ (.visitEnd =class) - ;; _ (prn 'SAVING_LAMBDA lambda-class) - ] + :let [_ (.visitEnd =class)] _ (&&/save-class! lambda-class (.toByteArray =class))] (instance-closure compile lambda-class ?env (lambda--signature ?env)))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index ad2c9d0c6..4e3e4add1 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -13,9 +13,7 @@ (lux.analyser [base :as &a] [module :as &a-module]) (lux.compiler [base :as &&] - [lambda :as &&lambda]) - ;; :reload - ) + [lambda :as &&lambda])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -68,13 +66,11 @@ (return nil))) (defn compile-record [compile *type* ?elems] - ;; (prn 'compile-record (str "{{" (->> ?elems &/|keys (&/|interpose " ") (&/fold str "")) "}}")) (|do [^MethodVisitor *writer* &/get-writer :let [elems* (->> ?elems &/->seq (sort #(compare (&/|first %1) (&/|first %2))) &/->list) - ;; _ (prn 'compile-record (str "{{" (->> elems* &/|keys (&/|interpose " ") (&/fold str "")) "}}")) num-elems (&/|length elems*) _ (doto *writer* (.visitLdcInsn (int num-elems)) @@ -111,7 +107,6 @@ (return nil))) (defn compile-captured [compile *type* ?scope ?captured-id ?source] - ;; (prn 'compile-captured ?scope ?captured-id) (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitVarInsn Opcodes/ALOAD 0) @@ -145,25 +140,18 @@ current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) (doto (.visitEnd))))] - ;; :let [_ (prn 'compile-def/pre-body)] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (|do [^MethodVisitor **writer** &/get-writer :let [_ (.visitCode **writer**)] - ;; :let [_ (prn 'compile-def/pre-body2)] _ (compile ?body) - ;; :let [_ (prn 'compile-def/post-body2)] :let [_ (doto **writer** (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))]] (return nil))) - ;; :let [_ (prn 'compile-def/post-body)] :let [_ (.visitEnd *writer*)] - ;; :let [_ (prn 'compile-def/_1 ?name current-class)] - _ (&&/save-class! current-class (.toByteArray =class)) - ;; :let [_ (prn 'compile-def/_2 ?name)] - ] + _ (&&/save-class! current-class (.toByteArray =class))] (return nil))) (defn compile-declare-macro [compile module name] diff --git a/src/lux/host.clj b/src/lux/host.clj index 80dfd78d5..783b61298 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -25,8 +25,7 @@ ))) (defn ^:private method->type [^Method method] - (|do [;; =args (&/map% class->type (&/->list (seq (.getParameterTypes method)))) - =return (class->type (.getReturnType method))] + (|do [=return (class->type (.getReturnType method))] (return =return))) ;; [Resources] @@ -46,7 +45,6 @@ (fail (str "[Analyser Error] Unknown class: " class-name)))))) (defn full-class-name [class-name] - ;; (prn 'full-class-name class-name) (|do [^Class =class (full-class class-name)] (return (.getName =class)))) @@ -116,7 +114,6 @@ (defn [target method-name args] (let [target (Class/forName target)] (if-let [method (first (for [^Method =method (.getMethods target) - ;; :let [_ (prn ' '=method =method (mapv #(.getName %) (.getParameterTypes =method)))] :when (and (= target (.getDeclaringClass =method)) (= method-name (.getName =method)) (= (Modifier/isStatic (.getModifiers =method))) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index b7729156a..eb4e7af7c 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -6,7 +6,6 @@ ;; [Utils] (defn ^:private escape-char [escaped] - ;; (prn 'escape-char escaped) (condp = escaped "\\t" (return "\t") "\\b" (return "\b") @@ -20,12 +19,8 @@ (defn ^:private lex-text-body [_] (&/try-all% (&/|list (|do [[_ [_ [prefix escaped]]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)") - ;; :let [_ (prn '[prefix escaped] [prefix escaped])] unescaped (escape-char escaped) - ;; :let [_ (prn 'unescaped unescaped)] - postfix (lex-text-body nil) - ;; :let [_ (prn 'postfix postfix)] - ] + postfix (lex-text-body nil)] (return (str prefix unescaped postfix))) (|do [[_ [_ body]] (&reader/read-regex #"(?s)^([^\"\\]*)")] (return body))))) @@ -54,9 +49,7 @@ (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) (def ^:private lex-comment - (&/try-all% (&/|list lex-single-line-comment - ;; (lex-multi-line-comment nil) - ))) + (&/try-all% (&/|list lex-single-line-comment))) (do-template [ ] (def @@ -111,10 +104,7 @@ (def ^:private lex-tag (|do [[_ [meta _]] (&reader/read-text "#") - ;; :let [_ (prn 'lex-tag)] - [_ [_ ident]] lex-ident - ;; :let [_ (prn 'lex-tag [(aget ident 0) (aget ident 1)])] - ] + [_ [_ ident]] lex-ident] (return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident)))))) (do-template [ ] diff --git a/src/lux/parser.clj b/src/lux/parser.clj index cb89f63a2..d8817fc05 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -22,19 +22,13 @@ ) (defn ^:private parse-record [parse] - (|do [;; :let [_ (prn 'parse-record 0)] - elems* (&/repeat% parse) - ;; :let [_ (prn 'parse-record 1)] + (|do [elems* (&/repeat% parse) token &lexer/lex - ;; :let [_ (prn 'parse-record 2)] - :let [elems (&/fold &/|++ (&/|list) elems*)] - ;; :let [_ (prn 'parse-record 3)] - ] + :let [elems (&/fold &/|++ (&/|list) elems*)]] (matchv ::M/objects [token] [["lux;Meta" [meta ["Close_Brace" _]]]] (if (even? (&/|length elems)) - (do ;; (prn 'PARSED_RECORD (&/|length elems)) - (return (&/V "lux;Record" (&/|as-pairs elems)))) + (return (&/V "lux;Record" (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) [_] @@ -42,10 +36,7 @@ ;; [Interface] (def parse - (|do [token &lexer/lex - ;; :let [_ (prn 'parse/token token)] - ;; :let [_ (prn 'parse (aget token 0))] - ] + (|do [token &lexer/lex] (matchv ::M/objects [token] [["lux;Meta" [meta ["White_Space" _]]]] (return (&/|list)) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index d66a671aa..38ff4d5e6 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -35,9 +35,7 @@ (fn [file-name line-num column-num ^String line] (if-let [[^String match] (re-find regex line)] (let [match-length (.length match) - line* (.substring line match-length) - ;; _ (prn 'with-line line*) - ] + line* (.substring line match-length)] (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match)) (if (empty? line*) (&/V "lux;None" nil) @@ -49,9 +47,7 @@ (fn [file-name line-num column-num ^String line] (if-let [[^String match tok1 tok2] (re-find regex line)] (let [match-length (.length match) - line* (.substring line match-length) - ;; _ (prn 'with-line line*) - ] + line* (.substring line match-length)] (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) (if (empty? line*) (&/V "lux;None" nil) @@ -61,12 +57,9 @@ (defn read-text [^String text] (with-line (fn [file-name line-num column-num ^String line] - ;; (prn 'read-text text line) (if (.startsWith line text) (let [match-length (.length text) - line* (.substring line match-length) - ;; _ (prn 'with-line line*) - ] + line* (.substring line match-length)] (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) text)) (if (empty? line*) (&/V "lux;None" nil) diff --git a/src/lux/type.clj b/src/lux/type.clj index 0df628b15..57c2d4624 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -190,29 +190,18 @@ (fail* (str "[Type Error] Unbound type-var: " id))) (fail* (str "[Type Error] Unknown type-var: " id)))))) -(defn set-var* [id type] - (fn [state] - (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %) - ts)) - state) - nil) - (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length)))))) - (defn set-var [id type] (fn [state] (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (do ;; (prn 'set-var (aget tvar 0)) - (matchv ::M/objects [tvar] - [["lux;Some" bound]] - (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) - - [["lux;None" _]] - (do ;; (prn 'set-var id (show-type type)) - (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %) - ts)) - state) - nil)))) + (matchv ::M/objects [tvar] + [["lux;Some" bound]] + (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) + + [["lux;None" _]] + (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %) + ts)) + state) + nil)) (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length)))))) ;; [Exports] @@ -251,10 +240,7 @@ [["lux;VarT" ?id*]] (if (= id ?id*) (return (&/T ?id (&/V "lux;None" nil))) - (return binding) - ;; (|do [?type** (clean* id ?type*)] - ;; (return (&/T ?id (&/V "lux;Some" ?type**)))) - ) + (return binding)) [_] (|do [?type** (clean* id ?type*)] @@ -275,11 +261,6 @@ _ (delete-var id)] (return output))) -;; (def delete-vars -;; (|do [vars #(->> % (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|keys (return* %)) -;; _ (&/map% delete-var vars)] -;; (return nil))) - (defn with-vars [amount k] (|do [=vars (&/map% (constantly create-var) (&/|range amount)) output (k (&/|map #(&/V "lux;VarT" %) =vars)) @@ -341,7 +322,6 @@ )) (defn clean [tvar type] - ;; (prn "^^ clean ^^") (matchv ::M/objects [tvar] [["lux;VarT" ?id]] (clean* ?id type) @@ -350,7 +330,6 @@ (fail (str "[Type Error] Not type-var: " (show-type tvar))))) (defn show-type [^objects type] - ;; (prn 'show-type (aget type 0)) (matchv ::M/objects [type] [["lux;DataT" name]] (str "(^ " name ")") @@ -413,34 +392,31 @@ )) (defn type= [x y] - ;; (prn "^^ type= ^^") (let [output (matchv ::M/objects [x y] [["lux;DataT" xname] ["lux;DataT" yname]] (= xname yname) [["lux;TupleT" xelems] ["lux;TupleT" yelems]] - (&/fold (fn [old xy] - (|let [[x* y*] xy] - (and old - (type= x* y*)))) - true - (&/zip2 xelems yelems)) + (&/fold2 (fn [old x y] + (and old (type= x y))) + true + xelems yelems) [["lux;VariantT" xcases] ["lux;VariantT" ycases]] - (and (= (&/|length xcases) (&/|length ycases)) - (&/fold (fn [old case] - (and old - (type= (&/|get case xcases) (&/|get case ycases)))) - true - (&/|keys xcases))) - - [["lux;RecordT" xfields] ["lux;RecordT" yfields]] - (and (= (&/|length xfields) (&/|length yfields)) - (&/fold (fn [old field] - (and old - (type= (&/|get field xfields) (&/|get field yfields)))) - true - (&/|keys xfields))) + (&/fold2 (fn [old xcase ycase] + (|let [[xname xtype] xcase + [yname ytype] ycase] + (and old (= xname yname) (type= xtype ytype)))) + true + xcases ycases) + + [["lux;RecordT" xslots] ["lux;RecordT" yslots]] + (&/fold2 (fn [old xslot yslot] + (|let [[xname xtype] xslot + [yname ytype] yslot] + (and old (= xname yname) (type= xtype ytype)))) + true + xslots yslots) [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] (and (type= xinput yinput) @@ -456,37 +432,30 @@ (= xid yid) [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]] - (and (type= xlambda ylambda) - (type= xparam yparam)) + (and (type= xlambda ylambda) (type= xparam yparam)) [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] - (do ;; (prn 'TESTING_ALLT - ;; 'NAME [xname yname] (= xname yname) - ;; 'ARG (= xarg yarg) - ;; 'LENGTH [(&/|length xenv) (&/|length yenv)] (= (&/|length xenv) (&/|length yenv))) - (and (= xname yname) - (= xarg yarg) - ;; (matchv ::M/objects [xenv yenv] - ;; [["lux;None" _] ["lux;None" _]] - ;; true - - ;; [["lux;Some" xenv*] ["lux;Some" yenv*]] - ;; (&/fold (fn [old bname] - ;; (and old - ;; (type= (&/|get bname xenv*) (&/|get bname yenv*)))) - ;; (= (&/|length xenv*) (&/|length yenv*)) - ;; (&/|keys xenv*)) - - ;; [_ _] - ;; false) - (type= xbody ybody) - )) + (and (= xname yname) + (= xarg yarg) + ;; (matchv ::M/objects [xenv yenv] + ;; [["lux;None" _] ["lux;None" _]] + ;; true + + ;; [["lux;Some" xenv*] ["lux;Some" yenv*]] + ;; (&/fold (fn [old bname] + ;; (and old + ;; (type= (&/|get bname xenv*) (&/|get bname yenv*)))) + ;; (= (&/|length xenv*) (&/|length yenv*)) + ;; (&/|keys xenv*)) + + ;; [_ _] + ;; false) + (type= xbody ybody) + ) [_ _] - (do ;; (prn 'type= (show-type x) (show-type y)) - false) + false )] - ;; (prn 'type= output (show-type x) (show-type y)) output)) (defn ^:private fp-get [k fixpoints] @@ -509,7 +478,6 @@ (str "Type " (show-type expected) " does not subsume type " (show-type actual))) (defn beta-reduce [env type] - ;; (prn 'beta-reduce (aget type 0)) (matchv ::M/objects [type] [["lux;VariantT" ?cases]] (&/V "lux;VariantT" (&/|map (fn [kv] @@ -559,11 +527,9 @@ (return* state type)))) (defn apply-type [type-fn param] - ;; (prn 'apply-type (aget type-fn 0) (aget param 0)) (matchv ::M/objects [type-fn] [["lux;AllT" [local-env local-name local-arg local-def]]] - (let [;; _ (prn 'apply-type/local-env (aget local-env 0) (show-type type-fn)) - local-env* (matchv ::M/objects [local-env] + (let [local-env* (matchv ::M/objects [local-env] [["lux;None" _]] (&/|table) @@ -584,9 +550,6 @@ (def init-fixpoints (&/|list)) (defn ^:private check* [fixpoints expected actual] - ;; (prn "^^ check* ^^") - ;; (prn 'check* (aget expected 0) (aget actual 0)) - ;; (prn 'check* (show-type expected) (show-type actual)) (matchv ::M/objects [expected actual] [["lux;VarT" ?eid] ["lux;VarT" ?aid]] (if (= ?eid ?aid) @@ -601,8 +564,6 @@ (return (&/V "lux;None" nil))))] (matchv ::M/objects [ebound abound] [["lux;None" _] ["lux;None" _]] - ;; (|do [_ (set-var ?aid expected)] - ;; (return (&/T fixpoints nil))) (|do [_ (set-var ?eid actual)] (return (&/T fixpoints nil))) @@ -613,8 +574,7 @@ (check* fixpoints expected atype) [["lux;Some" etype] ["lux;Some" atype]] - (check* fixpoints etype atype))) - ) + (check* fixpoints etype atype)))) [["lux;VarT" ?id] _] (&/try-all% (&/|list (|do [_ (set-var ?id actual)] @@ -635,10 +595,6 @@ _ (check* fixpoints A1 A2)] (return (&/T fixpoints nil))) - ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) - ;; [fixpoints** _] (check* fixpoints* A1 A2)] - ;; (return (&/T fixpoints** nil))) [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) e* (apply-type F2 A1) @@ -646,25 +602,15 @@ [fixpoints** _] (check* fixpoints* e* a*)] (return (&/T fixpoints** nil))) - ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) - ;; [fixpoints** _] (check* fixpoints* A1 A2)] - ;; (return (&/T fixpoints** nil))) [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) [fixpoints** _] (check* fixpoints* e* a*)] (return (&/T fixpoints** nil))) - - ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [F2 A2]]] - ;; (|do [[fixpoints* _] (check* (fp-put fp-pair true fixpoints) F1 F2) - ;; [fixpoints** _] (check* fixpoints* A1 A2)] - ;; (return (&/T fixpoints** nil))) [["lux;AppT" [F A]] _] (let [fp-pair (&/T expected actual) - ;; _ (prn 'LEFT_APP (&/|length fixpoints)) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) (&/|map (fn [pair] @@ -687,26 +633,6 @@ [_ ["lux;AppT" [F A]]] (|do [actual* (apply-type F A)] (check* fixpoints expected actual*)) - ;; (let [fp-pair (&/T expected actual) - ;; _ (prn 'RIGHT_APP (&/|length fixpoints)) - ;; _ (when (> (&/|length fixpoints) 10) - ;; (println 'FIXPOINTS (->> (&/|keys fixpoints) - ;; (&/|map (fn [pair] - ;; (|let [[e a] pair] - ;; (str (show-type e) ":+:" - ;; (show-type a))))) - ;; (&/|interpose "\n\n") - ;; (&/fold str ""))) - ;; (assert false))] - ;; (matchv ::M/objects [(fp-get fp-pair fixpoints)] - ;; [["lux;Some" ?]] - ;; (if ? - ;; (return (&/T fixpoints nil)) - ;; (fail (check-error expected actual))) - - ;; [["lux;None" _]] - ;; (|do [actual* (apply-type F A)] - ;; (check* (fp-put fp-pair true fixpoints) expected actual*)))) [["lux;AllT" _] _] (with-var @@ -779,48 +705,36 @@ (check* fixpoints* eO aO)) [["lux;TupleT" e!members] ["lux;TupleT" a!members]] - (if (= (&/|length e!members) (&/|length a!members)) - (|do [fixpoints* (&/fold% (fn [fixp ea] - (|let [[e a] ea] - (do ;; (prn "lux;TupleT" 'ITER (show-type e) (show-type a)) - (|do [[fixp* _] (check* fixp e a)] - (return fixp*))))) - fixpoints - (&/zip2 e!members a!members)) - ;; :let [_ (prn "lux;TupleT" 'DONE)] - ] - (return (&/T fixpoints* nil))) - (fail "[Type Error] Tuples don't match in size.")) + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* fp e a)] + (return fp*))) + fixpoints + e!members a!members)] + (return (&/T fixpoints* nil))) [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]] - (if (= (&/|length e!cases) (&/|length a!cases)) - (|do [fixpoints* (&/fold% (fn [fixp slot] - ;; (prn 'VARIANT_CASE slot) - (if-let [e!type (&/|get slot e!cases)] - (if-let [a!type (&/|get slot a!cases)] - (|do [[fixp* _] (check* fixp e!type a!type)] - (return fixp*)) - (fail (check-error expected actual))) - (fail (check-error expected actual)))) - fixpoints - (&/|keys e!cases))] - (return (&/T fixpoints* nil))) - (fail "[Type Error] Variants don't match in size.")) - - [["lux;RecordT" e!fields] ["lux;RecordT" a!fields]] - (if (= (&/|length e!fields) (&/|length a!fields)) - (|do [fixpoints* (&/fold% (fn [fixp slot] - ;; (prn 'RECORD_FIELD slot) - (if-let [e!type (&/|get slot e!fields)] - (if-let [a!type (&/|get slot a!fields)] - (|do [[fixp* _] (check* fixp e!type a!type)] - (return fixp*)) - (fail (check-error expected actual))) - (fail (check-error expected actual)))) - fixpoints - (&/|keys e!fields))] - (return (&/T fixpoints* nil))) - (fail "[Type Error] Records don't match in size.")) + (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] + (|let [[e!name e!type] e!case + [a!name a!type] a!case] + (if (= e!name a!name) + (|do [[fp* _] (check* fp e!type a!type)] + (return fp*)) + (fail (check-error expected actual))))) + fixpoints + e!cases a!cases)] + (return (&/T fixpoints* nil))) + + [["lux;RecordT" e!slots] ["lux;RecordT" a!slots]] + (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] + (|let [[e!name e!type] e!slot + [a!name a!type] a!slot] + (if (= e!name a!name) + (|do [[fp* _] (check* fp e!type a!type)] + (return fp*)) + (fail (check-error expected actual))))) + fixpoints + e!slots a!slots)] + (return (&/T fixpoints* nil))) [["lux;ExT" e!id] ["lux;ExT" a!id]] (if (= e!id a!id) @@ -832,7 +746,6 @@ )) (defn check [expected actual] - ;; (prn "^^ check ^^") (|do [_ (check* init-fixpoints expected actual)] (return nil))) -- cgit v1.2.3 From 94891d38a25ae4e4cec4471d04eace38b47357c6 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 6 May 2015 18:09:18 -0400 Subject: - Removed a few unused definitions inside lux.base --- src/lux/base.clj | 94 ++------------------------------------------------------ 1 file changed, 3 insertions(+), 91 deletions(-) diff --git a/src/lux/base.clj b/src/lux/base.clj index 283d06f52..d834915de 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -110,14 +110,6 @@ table* (V "lux;Cons" (T (T k v) (|remove slot table*)))))) -(defn |merge [table1 table2] - (matchv ::M/objects [table2] - [["lux;Nil" _]] - table1 - - [["lux;Cons" [[k v] table2*]]] - (|merge (|put k v table1) table2*))) - (defn |update [k f table] (matchv ::M/objects [table] [["lux;Nil" _]] @@ -180,15 +172,6 @@ (reverse (partition 2 steps)))) ;; [Resources/Combinators] -(defn try% [monad] - (fn [state] - (matchv ::M/objects [(monad state)] - [["lux;Right" [?state ?datum]]] - (return* ?state ?datum) - - [_] - (return* state nil)))) - (defn |cons [head tail] (V "lux;Cons" (T head tail))) @@ -360,62 +343,15 @@ (|list) xs)) -(defn show-table [table] - (str "{{" - (->> table - (|map (fn [kv] (|let [[k v] kv] (str k " = ???")))) - (|interpose " ") - (fold str "")) - "}}")) - -(defn apply% [monad call-state] - (fn [state] - (let [output (monad call-state)] - (matchv ::M/objects [output] - [["lux;Right" [?state ?datum]]] - (return* state ?datum) - - [_] - output)))) - (defn assert! [test message] (if test (return nil) (fail message))) -(defn comp% [f-m g-m] - (|do [temp g-m] - (f-m temp))) - -(defn pass [m-value] - (fn [state] - m-value)) - (def get-state (fn [state] (return* state state))) -(defn sequence% [m-values] - (matchv ::M/objects [m-values] - [["lux;Cons" [head tail]]] - (|do [_ head] - (sequence% tail)) - - [_] - (return nil))) - -(def source-consumed? - (fn [state] - (matchv ::M/objects [(get$ $SOURCE state)] - [["lux;None" _]] - (fail* "No source code.") - - [["lux;Some" ["lux;Nil" _]]] - (return* state true) - - [["lux;Some" _]] - (return* state false)))) - (defn try-all% [monads] (matchv ::M/objects [monads] [["lux;Nil" _]] @@ -449,12 +385,9 @@ ((exhaust% step) state*) [["lux;Left" msg]] - ((|do [? source-consumed?] - (if ? - (return nil) - (fail msg))) - state) - ))) + (if (= "[Reader Error] EOF" msg) + (return* state nil) + (fail* msg))))) (defn ^:private normalize-char [char] (case char @@ -532,14 +465,6 @@ +init-bindings+ )) -(defn from-some [some] - (matchv ::M/objects [some] - [["lux;Some" datum]] - datum - - [_] - (assert false))) - (def get-eval-ctor (fn [state] (return* (update$ $HOST #(update$ $EVAL-CTOR inc %) state) @@ -675,19 +600,6 @@ (|let [[?module ?name] ident] (str ?module ";" ?name))) -(defn map2% [f xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] - (|do [z (f x y) - zs (map2% f xs* ys*)] - (return (|cons z zs))) - - [["lux;Nil" _] ["lux;Nil" _]] - (return (V "lux;Nil" nil)) - - [_ _] - (fail "Lists don't match in size."))) - (defn fold2% [f init xs ys] (matchv ::M/objects [xs ys] [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] -- cgit v1.2.3 From c0bd1c6af6d1691ddc2627710e352a1bbe3eb1c7 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 6 May 2015 19:10:55 -0400 Subject: - Made some small optimizations in the compiler. --- src/lux/analyser/case.clj | 37 ++++++++++++++++++------------------- src/lux/analyser/host.clj | 7 +++---- src/lux/analyser/lux.clj | 24 +++++++++++------------- src/lux/base.clj | 26 ++++++++++++++++++++++++++ src/lux/compiler/case.clj | 13 +++++++------ src/lux/compiler/host.clj | 11 +++++------ src/lux/compiler/lux.clj | 35 +++++++++++++++++------------------ src/lux/host.clj | 43 ++++++++++++++++++------------------------- src/lux/reader.clj | 7 +++---- 9 files changed, 108 insertions(+), 95 deletions(-) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index cdcf40e0f..f18dc7836 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -169,10 +169,9 @@ [["TupleTotal" [total? ?values]] ["TupleTestAC" ?tests]] (if (= (&/|length ?values) (&/|length ?tests)) - (|do [structs (&/map% (fn [vt] - (|let [[v t] vt] - (merge-total v (&/T t ?body)))) - (&/zip2 ?values ?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.")) @@ -189,17 +188,18 @@ [["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]] (if (= (&/|length ?values) (&/|length ?tests)) - (|do [structs (&/map% (fn [lr] - (|let [[[lslot sub-struct] [rslot value]] lr] - (if (= lslot rslot) - (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] - (return (&/T lslot sub-struct*))) - (fail "[Pattern-matching error] Record slots mismatch.")))) - (&/zip2 ?values - (->> ?tests - &/->seq - (sort compare-kv) - &/->list)))] + (|do [structs (&/map2% (fn [left right] + (|let [[lslot sub-struct] left + [rslot value]right] + (if (= lslot rslot) + (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] + (return (&/T lslot sub-struct*))) + (fail "[Pattern-matching error] Record slots mismatch.")))) + ?values + (->> ?tests + &/->seq + (sort compare-kv) + &/->list))] (return (&/V "RecordTotal" (&/T total? structs)))) (fail "[Pattern-matching error] Inconsistent record-size.")) @@ -238,10 +238,9 @@ (return true) (matchv ::M/objects [value-type] [["lux;TupleT" ?members]] - (|do [totals (&/map% (fn [sv] - (|let [[sub-struct ?member] sv] - (check-totality ?member sub-struct))) - (&/zip2 ?structs ?members))] + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) [_] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index d57493439..0d9fb1333 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -111,10 +111,9 @@ =classes (&/map% &host/extract-jvm-param ?classes) =return (&host/lookup-virtual-method =class ?method =classes) =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) - =args (&/map% (fn [c+o] - (|let [[?c ?o] c+o] - (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o))) - (&/zip2 =classes ?args))] + =args (&/map2% (fn [?c ?o] + (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) + =classes ?args)] (return (&/|list (&/T (&/V (&/T =class ?method =classes =object =args)) =return))))) analyse-jvm-invokevirtual "jvm-invokevirtual" diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index d461d5b6b..26376ad60 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -27,10 +27,9 @@ (|do [exo-type* (&type/actual-type exo-type)] (matchv ::M/objects [exo-type*] [["lux;TupleT" ?members]] - (|do [=elems (&/map% (fn [ve] - (|let [[elem-t elem] ve] - (&&/analyse-1 analyse elem-t elem))) - (&/zip2 ?members ?elems))] + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems)] (return (&/|list (&/T (&/V "tuple" =elems) exo-type)))) @@ -160,15 +159,14 @@ (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) (&/|map #(&/get$ &/$NAME %) outer) (&/|reverse inner))) - [=local inner*] (&/fold (fn [register+new-inner frame+in-scope] - (|let [[register new-inner] register+new-inner - [frame in-scope] frame+in-scope - [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ident register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) - (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) - (&/|list)) - (&/zip2 (&/|reverse inner) scopes))] + [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] + (|let [[register new-inner] register+new-inner + [register* frame*] (&&lambda/close-over (&/|cons module-name (&/|reverse in-scope)) ident register frame)] + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) + (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) + (&/|list)) + (&/|reverse inner) scopes)] (&/run-state (|do [btype (&&/expr-type =local) _ (&type/check exo-type btype)] (return (&/|list =local))) diff --git a/src/lux/base.clj b/src/lux/base.clj index d834915de..5292faffa 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -612,6 +612,19 @@ [_ _] (fail "Lists don't match in size."))) +(defn map2% [f xs ys] + (matchv ::M/objects [xs ys] + [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|do [z (f x y) + zs (map2% f xs* ys*)] + (return (|cons z zs))) + + [["lux;Nil" _] ["lux;Nil" _]] + (return (V "lux;Nil" nil)) + + [_ _] + (fail "Lists don't match in size."))) + (defn fold2 [f init xs ys] (matchv ::M/objects [xs ys] [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] @@ -623,3 +636,16 @@ [_ _] false)) + +(defn enumerate* [idx xs] + (matchv ::M/objects [xs] + [["lux;Cons" [x xs*]]] + (V "lux;Cons" (T (T idx x) + (enumerate* (inc idx) xs*))) + + [["lux;Nil" _]] + xs + )) + +(defn enumerate [xs] + (enumerate* 0 xs)) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 2720e31f7..37847f553 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -92,7 +92,7 @@ (->> (|let [[idx test] idx+member $next (new Label) $sub-else (new Label)]) - (doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?members)) ?members))]))) + (doseq [idx+member (->> ?members &/enumerate &/->seq)]))) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) @@ -110,11 +110,12 @@ (->> (|let [[idx [_ test]] idx+member $next (new Label) $sub-else (new Label)]) - (doseq [idx+member (&/->seq (&/zip2 (&/|range (&/|length ?slots)) - (->> ?slots - &/->seq - (sort compare-kv) - &/->list)))]))) + (doseq [idx+member (->> ?slots + &/->seq + (sort compare-kv) + &/->list + &/enumerate + &/->seq)]))) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 429424240..8782acfa5 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -202,12 +202,11 @@ :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] _ (compile ?object) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] - _ (&/map% (fn [class-name+arg] - (|let [[class-name arg] class-name+arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret)))) - (&/zip2 ?classes ?args)) + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) :let [_ (doto *writer* (.visitMethodInsn (&host/->class ?class) ?method method-sig) (prepare-return! *type*))]] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 4e3e4add1..491cf62fb 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -54,15 +54,14 @@ _ (doto *writer* (.visitLdcInsn (int num-elems)) (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))] - _ (&/map% (fn [idx+elem] - (|let [[idx elem] idx+elem] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret)))) - (&/zip2 (&/|range num-elems) ?elems))] + _ (&/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)] (return nil))) (defn compile-record [compile *type* ?elems] @@ -75,15 +74,15 @@ _ (doto *writer* (.visitLdcInsn (int num-elems)) (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))] - _ (&/map% (fn [idx+kv] - (|let [[idx [k v]] idx+kv] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile v) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret)))) - (&/zip2 (&/|range num-elems) elems*))] + _ (&/map2% (fn [idx kv] + (|let [[k v] kv] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + ret (compile v) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return ret)))) + (&/|range num-elems) elems*)] (return nil))) (defn compile-variant [compile *type* ?tag ?value] diff --git a/src/lux/host.clj b/src/lux/host.clj index 783b61298..55a772fcc 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -54,7 +54,7 @@ (def ->package ->class) (defn ->type-signature [class] - (assert (string? class)) + ;; (assert (string? class)) (case class "void" "V" "boolean" "Z" @@ -96,15 +96,13 @@ (do-template [ ] (defn [target field] - (let [target (Class/forName target)] - (if-let [type* (first (for [^Field =field (.getFields target) - :when (and (= target (.getDeclaringClass =field)) - (= field (.getName =field)) - (= (Modifier/isStatic (.getModifiers =field))))] - (.getType =field)))] - (|do [=type (class->type type*)] - (return =type)) - (fail (str "[Analyser Error] Field does not exist: " target field))))) + (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName target)) + :when (and (= field (.getName =field)) + (= (Modifier/isStatic (.getModifiers =field))))] + (.getType =field)))] + (|do [=type (class->type type*)] + (return =type)) + (fail (str "[Analyser Error] Field does not exist: " target "." field)))) lookup-static-field true lookup-field false @@ -112,21 +110,16 @@ (do-template [ ] (defn [target method-name args] - (let [target (Class/forName target)] - (if-let [method (first (for [^Method =method (.getMethods target) - :when (and (= target (.getDeclaringClass =method)) - (= method-name (.getName =method)) - (= (Modifier/isStatic (.getModifiers =method))) - (&/fold #(and %1 %2) - true - (&/|map (fn [xy] - (|let [[x y] xy] - (= x y))) - (&/zip2 args - (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))))] - =method))] - (method->type method) - (fail (str "[Analyser Error] Method does not exist: " target method-name))))) + (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName target)) + :when (and (= method-name (.getName =method)) + (= (Modifier/isStatic (.getModifiers =method))) + (&/fold2 #(and %1 (= %2 %3)) + true + args + (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))] + =method))] + (method->type method) + (fail (str "[Analyser Error] Method does not exist: " target "." method-name)))) lookup-static-method true lookup-virtual-method false diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 38ff4d5e6..3c5f0066d 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -69,14 +69,13 @@ (defn from [file-name] (let [lines (&/->list (string/split-lines (slurp file-name)))] (&/|map (fn [line+line-num] - (|let [[line line-num] line+line-num] + (|let [[line-num line] line+line-num] (&/V "lux;Meta" (&/T (&/T file-name line-num 0) line)))) (&/|filter (fn [line+line-num] - (|let [[line line-num] line+line-num] + (|let [[line-num line] line+line-num] (not (empty? line)))) - (&/zip2 lines - (&/|range (&/|length lines))))))) + (&/enumerate lines))))) (def current-line (fn [state] -- cgit v1.2.3 From 7f39dd6a229b3b5a8e8d4108ecd1f5307b3cbf06 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 6 May 2015 23:44:24 -0400 Subject: - Made several optimizations to the compiler. - Also removed several unused definitions. --- project.clj | 4 +-- source/lux.lux | 4 +-- src/lux/analyser.clj | 5 +-- src/lux/analyser/base.clj | 7 ---- src/lux/analyser/env.clj | 6 ---- src/lux/analyser/host.clj | 44 ++++++++++--------------- src/lux/analyser/lux.clj | 9 ++--- src/lux/compiler.clj | 2 +- src/lux/compiler/case.clj | 80 +++++++++++++++++++++------------------------ src/lux/compiler/lambda.clj | 16 +++------ src/lux/compiler/lux.clj | 45 ++++++++++++------------- src/lux/host.clj | 21 +----------- src/lux/lexer.clj | 4 ++- src/lux/parser.clj | 66 +++++++++++++++++++------------------ src/lux/reader.clj | 77 ++++++++++++++++++++----------------------- src/lux/type.clj | 38 +++++++++------------ 16 files changed, 181 insertions(+), 247 deletions(-) diff --git a/project.clj b/project.clj index 9f647fcd4..a0fd8d1cb 100644 --- a/project.clj +++ b/project.clj @@ -1,6 +1,6 @@ -(defproject lux-jvm "0.1.0" +(defproject lux-jvm "0.2.0" :description "The JVM compiler for the Lux programming language." - :url "http://example.com/FIXME" + :url "https://github.com/LuxLang/lux" :license {:name "Eclipse Public License" :url "http://www.eclipse.org/legal/epl-v10.html"} :dependencies [[org.clojure/clojure "1.6.0"] diff --git a/source/lux.lux b/source/lux.lux index acaee2265..5b59d788f 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -237,7 +237,7 @@ (export' LuxVar) ## (deftype #rec CompilerState -## (& #source (Maybe Reader) +## (& #source Reader ## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax))))))))) ## #module-aliases (List Void) ## #envs (List (Env Text (, LuxVar Type))) @@ -245,7 +245,7 @@ ## #host HostState)) (def' CompilerState (#AppT [(#AllT [#None "CompilerState" "" - (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])] + (#RecordT (#Cons [["lux;source" Reader] (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text (#Cons [(#AppT [List (#TupleT (#Cons [Text (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index eefb5b41c..8fad07dfa 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -26,9 +26,6 @@ ["lux;Nil" _]]]]]]]]] (&/T catch+ ?finally-body))) -(defn ^:private _meta [token] - (&/V "lux;Meta" (&/T (&/T "" -1 -1) token))) - (defn ^:private aba1 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Standard special forms @@ -59,7 +56,7 @@ (&&lux/analyse-record analyse exo-type ?elems) [["lux;Meta" [meta ["lux;Tag" ?ident]]]] - (&&lux/analyse-variant analyse exo-type ?ident (_meta (&/V "lux;Tuple" (|list)))) + (&&lux/analyse-variant analyse exo-type ?ident (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;Tuple" (|list))))) [["lux;Meta" [meta ["lux;Symbol" [_ "jvm-null"]]]]] (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index b16025349..a4c96c350 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -25,10 +25,3 @@ &/get-module-name (return ?module))] (return (&/ident->text (&/T module* ?name)))))) - -(defn resolved-ident* [ident] - (|let [[?module ?name] ident] - (|do [module* (if (= "" ?module) - &/get-module-name - (return ?module))] - (return (&/T module* ?name))))) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 77fba3ca0..fa7b9aa1a 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -34,12 +34,6 @@ [_] =return)))) -(defn with-locals [locals monad] - (reduce (fn [inner [label elem]] - (with-local label elem inner)) - monad - (reverse locals))) - (def captured-vars (fn [state] (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 0d9fb1333..3631bddb2 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -75,46 +75,40 @@ ) (defn analyse-jvm-getstatic [analyse ?class ?field] - (|do [=class (&host/full-class-name ?class) - =type (&host/lookup-static-field =class ?field)] - (return (&/|list (&/T (&/V "jvm-getstatic" (&/T =class ?field)) =type))))) + (|do [=type (&host/lookup-static-field ?class ?field)] + (return (&/|list (&/T (&/V "jvm-getstatic" (&/T ?class ?field)) =type))))) (defn analyse-jvm-getfield [analyse ?class ?field ?object] - (|do [=class (&host/full-class-name ?class) - =type (&host/lookup-static-field =class ?field) + (|do [=type (&host/lookup-static-field ?class ?field) =object (&&/analyse-1 analyse ?object)] - (return (&/|list (&/T (&/V "jvm-getfield" (&/T =class ?field =object)) =type))))) + (return (&/|list (&/T (&/V "jvm-getfield" (&/T ?class ?field =object)) =type))))) (defn analyse-jvm-putstatic [analyse ?class ?field ?value] - (|do [=class (&host/full-class-name ?class) - =type (&host/lookup-static-field =class ?field) + (|do [=type (&host/lookup-static-field ?class ?field) =value (&&/analyse-1 analyse ?value)] - (return (&/|list (&/T (&/V "jvm-putstatic" (&/T =class ?field =value)) =type))))) + (return (&/|list (&/T (&/V "jvm-putstatic" (&/T ?class ?field =value)) =type))))) (defn analyse-jvm-putfield [analyse ?class ?field ?object ?value] - (|do [=class (&host/full-class-name ?class) - =type (&host/lookup-static-field =class ?field) + (|do [=type (&host/lookup-static-field ?class ?field) =object (&&/analyse-1 analyse ?object) =value (&&/analyse-1 analyse ?value)] - (return (&/|list (&/T (&/V "jvm-putfield" (&/T =class ?field =object =value)) =type))))) + (return (&/|list (&/T (&/V "jvm-putfield" (&/T ?class ?field =object =value)) =type))))) (defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args] - (|do [=class (&host/full-class-name ?class) - =classes (&/map% &host/extract-jvm-param ?classes) - =return (&host/lookup-static-method =class ?method =classes) + (|do [=classes (&/map% &host/extract-jvm-param ?classes) + =return (&host/lookup-static-method ?class ?method =classes) =args (&/flat-map% analyse ?args)] - (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T =class ?method =classes =args)) =return))))) + (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T ?class ?method =classes =args)) =return))))) (do-template [ ] (defn [analyse ?class ?method ?classes ?object ?args] - (|do [=class (&host/full-class-name ?class) - =classes (&/map% &host/extract-jvm-param ?classes) - =return (&host/lookup-virtual-method =class ?method =classes) + (|do [=classes (&/map% &host/extract-jvm-param ?classes) + =return (&host/lookup-virtual-method ?class ?method =classes) =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) =classes ?args)] - (return (&/|list (&/T (&/V (&/T =class ?method =classes =object =args)) =return))))) + (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) =return))))) analyse-jvm-invokevirtual "jvm-invokevirtual" analyse-jvm-invokeinterface "jvm-invokeinterface" @@ -126,15 +120,13 @@ (return (&/|list (&/T (&/V "jvm-null?" =object) (&/V "lux;DataT" "java.lang.Boolean")))))) (defn analyse-jvm-new [analyse ?class ?classes ?args] - (|do [=class (&host/full-class-name ?class) - =classes (&/map% &host/extract-jvm-param ?classes) + (|do [=classes (&/map% &host/extract-jvm-param ?classes) =args (&/flat-map% analyse ?args)] - (return (&/|list (&/T (&/V "jvm-new" (&/T =class =classes =args)) (&/V "lux;DataT" =class)))))) + (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) (&/V "lux;DataT" ?class)))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (|do [=class (&host/full-class-name ?class)] - (return (&/|list (&/T (&/V "jvm-new-array" (&/T =class ?length)) (&/V "array" (&/T (&/V "lux;DataT" =class) - (&/V "lux;Nil" nil)))))))) + (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V "lux;DataT" ?class) + (&/V "lux;Nil" nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (&&/analyse-1 analyse &type/$Void ?array) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 26376ad60..df87a08b6 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -45,8 +45,7 @@ (defn analyse-variant [analyse exo-type ident ?value] (|do [exo-type* (matchv ::M/objects [exo-type] [["lux;VarT" ?id]] - (&/try-all% (&/|list (|do [exo-type* (&/try-all% (&/|list (&type/deref ?id) - (fail "##8##")))] + (&/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)))) @@ -74,8 +73,7 @@ (defn analyse-record [analyse exo-type ?elems] (|do [exo-type* (matchv ::M/objects [exo-type] [["lux;VarT" ?id]] - (|do [exo-type* (&/try-all% (&/|list (&type/deref ?id) - (fail "##7##")))] + (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) [_] @@ -265,8 +263,7 @@ [["lux;VarT" ?id]] (|do [? (&type/bound? ?id)] (if ? - (|do [dtype (&/try-all% (&/|list (&type/deref ?id) - (fail "##6##")))] + (|do [dtype (&type/deref ?id)] (matchv ::M/objects [dtype] [["lux;ExT" _]] (return (&/T _expr exo-type)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index f970540c9..209e29626 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -353,7 +353,7 @@ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (&host/->class name) nil "java/lang/Object" nil))] (matchv ::M/objects [(&/run-state (&/exhaust% compiler-step) (->> state - (&/set$ &/$SOURCE (&/V "lux;Some" (&reader/from (str "source/" name ".lux")))) + (&/set$ &/$SOURCE (&reader/from (str "source/" name ".lux"))) (&/set$ &/$ENVS (&/|list (&/env name))) (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %)) (&/update$ &/$MODULES #(&/|put name &a-module/init-module %))))] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 37847f553..1a0a9c6bc 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -16,10 +16,7 @@ MethodVisitor))) ;; [Utils] -(let [+tag-sig+ (&host/->type-signature "java.lang.String") - +oclass+ (&host/->class "java.lang.Object") - +equals-sig+ (str "(" (&host/->type-signature "java.lang.Object") ")Z") - compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] +(let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private compile-match [^MethodVisitor writer ?match $target $else] (matchv ::M/objects [?match] [["StoreTestAC" ?idx]] @@ -29,9 +26,9 @@ [["BoolTestAC" ?value]] (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Boolean")) + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean") (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Boolean") "booleanValue" "()Z") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Boolean" "booleanValue" "()Z") (.visitLdcInsn ?value) (.visitJumpInsn Opcodes/IF_ICMPNE $else) (.visitInsn Opcodes/POP) @@ -39,9 +36,9 @@ [["IntTestAC" ?value]] (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Long")) + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Long") "longValue" "()J") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Long" "longValue" "()J") (.visitLdcInsn ?value) (.visitInsn Opcodes/LCMP) (.visitJumpInsn Opcodes/IFNE $else) @@ -50,9 +47,9 @@ [["RealTestAC" ?value]] (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Double")) + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Double") "doubleValue" "()D") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Double" "doubleValue" "()D") (.visitLdcInsn ?value) (.visitInsn Opcodes/DCMPL) (.visitJumpInsn Opcodes/IFNE $else) @@ -61,9 +58,9 @@ [["CharTestAC" ?value]] (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Character")) + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character") (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Character") "charValue" "()C") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Character" "charValue" "()C") (.visitLdcInsn ?value) (.visitJumpInsn Opcodes/IF_ICMPNE $else) (.visitInsn Opcodes/POP) @@ -73,7 +70,7 @@ (doto writer (.visitInsn Opcodes/DUP) (.visitLdcInsn ?value) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Object") "equals" (str "(" (&host/->type-signature "java.lang.Object") ")Z")) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") (.visitJumpInsn Opcodes/IFEQ $else) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) @@ -126,7 +123,7 @@ (.visitLdcInsn (int 0)) (.visitInsn Opcodes/AALOAD) (.visitLdcInsn ?tag) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +oclass+ "equals" +equals-sig+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") (.visitJumpInsn Opcodes/IFEQ $else) (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 1)) @@ -151,34 +148,33 @@ patterns)] (&/T mappings (&/|reverse patterns*)))) -(let [ex-class (&host/->class "java.lang.IllegalStateException")] - (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)))) - mappings) - mappings* (&/|map &/|first entries)] - (doto writer - (-> (doto (compile-match ?match (&/|get ?body mappings*) $else) - (.visitLabel $else)) - (->> (|let [[?body ?match] ?body+?match]) - (doseq [?body+?match (&/->seq patterns) - :let [$else (new Label)]]))) - (.visitInsn Opcodes/POP) - (.visitTypeInsn Opcodes/NEW ex-class) - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "" "()V") - (.visitInsn Opcodes/ATHROW)) - (&/map% (fn [?label+?body] - (|let [[?label ?body] ?label+?body] - (|do [:let [_ (.visitLabel writer ?label)] - ret (compile ?body) - :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] - (return ret)))) - (&/|map &/|second entries)) - ))) +(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)))) + mappings) + mappings* (&/|map &/|first entries)] + (doto writer + (-> (doto (compile-match ?match (&/|get ?body mappings*) $else) + (.visitLabel $else)) + (->> (|let [[?body ?match] ?body+?match]) + (doseq [?body+?match (&/->seq patterns) + :let [$else (new Label)]]))) + (.visitInsn Opcodes/POP) + (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "()V") + (.visitInsn Opcodes/ATHROW)) + (&/map% (fn [?label+?body] + (|let [[?label ?body] ?label+?body] + (|do [:let [_ (.visitLabel writer ?label)] + ret (compile ?body) + :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] + (return ret)))) + (&/|map &/|second entries)) + )) ;; [Resources] (defn compile-case [compile *type* ?value ?matches] diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 3ba6e52f1..65c7e58aa 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -79,17 +79,11 @@ :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW lambda-class) (.visitInsn Opcodes/DUP))] - _ (->> closed-over - &/->seq - (sort #(matchv ::M/objects [(&/|second %1) (&/|second %2)] - [[["captured" [_ ?cid1 _]] _] - [["captured" [_ ?cid2 _]] _]] - (< ?cid1 ?cid2))) - &/->list - (&/map% (fn [?name+?captured] - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ _ ?source]] _]]] - (compile ?source))))) + _ (&/map% (fn [?name+?captured] + (matchv ::M/objects [?name+?captured] + [[?name [["captured" [_ _ ?source]] _]]] + (compile ?source))) + closed-over) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature)]] (return nil))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 491cf62fb..cf4a65f04 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -20,27 +20,24 @@ MethodVisitor))) ;; [Exports] -(let [+class+ (&host/->class "java.lang.Boolean") - +sig+ (&host/->type-signature "java.lang.Boolean")] - (defn compile-bool [compile *type* ?value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") (if ?value "TRUE" "FALSE") (&host/->type-signature "java.lang.Boolean"))]] - (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 [ ] - (let [+class+ (&host/->class )] - (defn [compile *type* value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW +class+) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ( value)) - (.visitMethodInsn Opcodes/INVOKESPECIAL +class+ "" ))]] - (return nil)))) + (defn [compile *type* value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW ) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ( value)) + (.visitMethodInsn Opcodes/INVOKESPECIAL "" ))]] + (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 "java/lang/Long" "(J)V" long + compile-real "java/lang/Double" "(D)V" double + compile-char "java/lang/Character" "(C)V" char ) (defn compile-text [compile *type* ?value] @@ -53,7 +50,7 @@ :let [num-elems (&/|length ?elems) _ (doto *writer* (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))] + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] _ (&/map2% (fn [idx elem] (|do [:let [_ (doto *writer* (.visitInsn Opcodes/DUP) @@ -73,7 +70,7 @@ num-elems (&/|length elems*) _ (doto *writer* (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")))] + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] _ (&/map2% (fn [idx kv] (|let [[k v] kv] (|do [:let [_ (doto *writer* @@ -89,7 +86,7 @@ (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int 2)) - (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) (.visitLdcInsn ?tag) @@ -124,19 +121,19 @@ (|do [^MethodVisitor *writer* &/get-writer _ (compile ?fn) _ (compile ?arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]] + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature)]] (return nil))) (defn compile-def [compile ?name ?body ?def-data] (|do [^ClassWriter *writer* &/get-writer module-name &/get-module-name :let [outer-class (&host/->class module-name) - datum-sig (&host/->type-signature "java.lang.Object") + datum-sig "Ljava/lang/Object;" current-class (&host/location (&/|list outer-class ?name)) _ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) + current-class nil "java/lang/Object" (into-array ["lux/Function"])) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) (doto (.visitEnd))))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) diff --git a/src/lux/host.clj b/src/lux/host.clj index 55a772fcc..d159d2608 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -29,25 +29,6 @@ (return =return))) ;; [Resources] -(defn full-class [class-name] - (case class-name - "boolean" (return Boolean/TYPE) - "byte" (return Byte/TYPE) - "short" (return Short/TYPE) - "int" (return Integer/TYPE) - "long" (return Long/TYPE) - "float" (return Float/TYPE) - "double" (return Double/TYPE) - "char" (return Character/TYPE) - ;; else - (try (return (Class/forName class-name)) - (catch Exception e - (fail (str "[Analyser Error] Unknown class: " class-name)))))) - -(defn full-class-name [class-name] - (|do [^Class =class (full-class class-name)] - (return (.getName =class)))) - (defn ^String ->class [class] (string/replace class #"\." "/")) @@ -89,7 +70,7 @@ (defn extract-jvm-param [token] (matchv ::M/objects [token] [["lux;Meta" [_ ["lux;Symbol" [_ ?ident]]]]] - (full-class-name ?ident) + (return ?ident) [_] (fail (str "[Host] Unknown JVM param: " (pr-str token))))) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index eb4e7af7c..f94a3d058 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -25,7 +25,9 @@ (|do [[_ [_ body]] (&reader/read-regex #"(?s)^([^\"\\]*)")] (return body))))) -(def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)") +(def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)" + ;; #"^([^0-9\[\]\(\)\{\};#\s\"][^\[\]\(\)\{\};#\s\"]*)" + ) ;; [Lexers] (def ^:private lex-white-space diff --git a/src/lux/parser.clj b/src/lux/parser.clj index d8817fc05..6b392ea96 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -38,45 +38,47 @@ (def parse (|do [token &lexer/lex] (matchv ::M/objects [token] - [["lux;Meta" [meta ["White_Space" _]]]] - (return (&/|list)) + [["lux;Meta" [meta token*]]] + (matchv ::M/objects [token*] + [["White_Space" _]] + (return (&/|list)) - [["lux;Meta" [meta ["Comment" _]]]] - (return (&/|list)) - - [["lux;Meta" [meta ["Bool" ?value]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Bool" (Boolean/parseBoolean ?value)))))) + [["Comment" _]] + (return (&/|list)) + + [["Bool" ?value]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Bool" (Boolean/parseBoolean ?value)))))) - [["lux;Meta" [meta ["Int" ?value]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Int" (Integer/parseInt ?value)))))) + [["Int" ?value]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Int" (Integer/parseInt ?value)))))) - [["lux;Meta" [meta ["Real" ?value]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Real" (Float/parseFloat ?value)))))) + [["Real" ?value]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Real" (Float/parseFloat ?value)))))) - [["lux;Meta" [meta ["Char" ^String ?value]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Char" (.charAt ?value 0)))))) + [["Char" ^String ?value]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Char" (.charAt ?value 0)))))) - [["lux;Meta" [meta ["Text" ?value]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Text" ?value))))) + [["Text" ?value]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Text" ?value))))) - [["lux;Meta" [meta ["Symbol" ?ident]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Symbol" ?ident))))) + [["Symbol" ?ident]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Symbol" ?ident))))) - [["lux;Meta" [meta ["Tag" ?ident]]]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Tag" ?ident))))) + [["Tag" ?ident]] + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Tag" ?ident))))) - [["lux;Meta" [meta ["Open_Paren" _]]]] - (|do [syntax (parse-form parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - - [["lux;Meta" [meta ["Open_Bracket" _]]]] - (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + [["Open_Paren" _]] + (|do [syntax (parse-form parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + + [["Open_Bracket" _]] + (|do [syntax (parse-tuple parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - [["lux;Meta" [meta ["Open_Brace" _]]]] - (|do [syntax (parse-record parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + [["Open_Brace" _]] + (|do [syntax (parse-record parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - [_] - (fail "[Parser Error] Unknown lexer token.") - ))) + [_] + (fail "[Parser Error] Unknown lexer token.") + )))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 3c5f0066d..6a954d5ff 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -8,50 +8,59 @@ (defn ^:private with-line [body] (fn [state] (matchv ::M/objects [(&/get$ &/$SOURCE state)] - [["lux;None" _]] - (fail* "[Reader Error] No source code.") - - [["lux;Some" ["lux;Nil" _]]] + [["lux;Nil" _]] (fail* "[Reader Error] EOF") - [["lux;Some" ["lux;Cons" [["lux;Meta" [[file-name line-num column-num] line]] - more]]]] + [["lux;Cons" [["lux;Meta" [[file-name line-num column-num] line]] + more]]] (matchv ::M/objects [(body file-name line-num column-num line)] [["No" msg]] (fail* msg) - [["Yes" [meta ["lux;None" _]]]] - (return* (&/set$ &/$SOURCE (&/V "lux;Some" more) state) - meta) + [["Done" output]] + (return* (&/set$ &/$SOURCE more state) + output) - [["Yes" [meta ["lux;Some" line-meta]]]] - (return* (&/set$ &/$SOURCE (&/V "lux;Some" (&/|cons line-meta more)) state) - meta)) + [["Yes" [output line*]]] + (return* (&/set$ &/$SOURCE (&/|cons line* more) state) + output)) ))) ;; [Exports] +(defn ^:private re-find! [regex line] + (let [matcher (.matcher regex line)] + (when (.find matcher) + (.group matcher 0)))) + +(defn ^:private re-find3! [regex line] + (let [matcher (.matcher regex line)] + (when (.find matcher) + (list (.group matcher 0) + (.group matcher 1) + (.group matcher 2))))) + (defn read-regex [regex] (with-line (fn [file-name line-num column-num ^String line] - (if-let [[^String match] (re-find regex line)] + (if-let [^String match (re-find! regex line)] (let [match-length (.length match) line* (.substring line match-length)] - (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match)) - (if (empty? line*) - (&/V "lux;None" nil) - (&/V "lux;Some" (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*))))))) + (if (empty? line*) + (&/V "Done" (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match))) + (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match)) + (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))) (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line (fn [file-name line-num column-num ^String line] - (if-let [[^String match tok1 tok2] (re-find regex line)] + (if-let [[^String match tok1 tok2] (re-find3! regex line)] (let [match-length (.length match) line* (.substring line match-length)] - (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) - (if (empty? line*) - (&/V "lux;None" nil) - (&/V "lux;Some" (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*))))))) + (if (empty? line*) + (&/V "Done" (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)))) + (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) + (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))) (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) (defn read-text [^String text] @@ -60,10 +69,10 @@ (if (.startsWith line text) (let [match-length (.length text) line* (.substring line match-length)] - (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) text)) - (if (empty? line*) - (&/V "lux;None" nil) - (&/V "lux;Some" (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*))))))) + (if (empty? line*) + (&/V "Done" (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) text))) + (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) text)) + (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))) (&/V "No" (str "[Reader Error] Text failed: " text)))))) (defn from [file-name] @@ -74,19 +83,5 @@ line)))) (&/|filter (fn [line+line-num] (|let [[line-num line] line+line-num] - (not (empty? line)))) + (not= "" line))) (&/enumerate lines))))) - -(def current-line - (fn [state] - (matchv ::M/objects [(&/get$ &/$SOURCE state)] - [["lux;None" _]] - (fail* "[Reader Error] No source code.") - - [["lux;Some" ["lux;Nil" _]]] - (fail* "[Reader Error] EOF") - - [["lux;Some" ["lux;Cons" [["lux;Meta" [_ line]] - more]]]] - (return* state line) - ))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 57c2d4624..2e9e85092 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -142,7 +142,7 @@ (def CompilerState (&/V "lux;AppT" (&/T (fAll "CompilerState" "" (&/V "lux;RecordT" - (&/|list (&/T "lux;source" (&/V "lux;AppT" (&/T Maybe Reader))) + (&/|list (&/T "lux;source" Reader) (&/T "lux;modules" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" @@ -180,15 +180,14 @@ (defn deref [id] (fn [state] - (let [mappings (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS))] - (if-let [type* (->> mappings (&/|get id))] - (matchv ::M/objects [type*] - [["lux;Some" type]] - (return* state type) - - [["lux;None" _]] - (fail* (str "[Type Error] Unbound type-var: " id))) - (fail* (str "[Type Error] Unknown type-var: " id)))))) + (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] + (matchv ::M/objects [type*] + [["lux;Some" type]] + (return* state type) + + [["lux;None" _]] + (fail* (str "[Type Error] Unbound type-var: " id))) + (fail* (str "[Type Error] Unknown type-var: " id))))) (defn set-var [id type] (fn [state] @@ -210,8 +209,8 @@ (fn [state] (let [id (->> state (&/get$ &/$TYPES) (&/get$ &/$COUNTER))] (return* (&/update$ &/$TYPES #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V "lux;None" nil) ms)))) + (&/update$ &/$COUNTER inc) + (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V "lux;None" nil) ms)))) state) id)))) @@ -271,8 +270,7 @@ (matchv ::M/objects [type] [["lux;VarT" ?id]] (if (= ?tid ?id) - (&/try-all% (&/|list (deref ?id) - (fail "##5##"))) + (deref ?id) (return type)) [["lux;LambdaT" [?arg ?return]]] @@ -554,12 +552,10 @@ [["lux;VarT" ?eid] ["lux;VarT" ?aid]] (if (= ?eid ?aid) (return (&/T fixpoints nil)) - (|do [ebound (&/try-all% (&/|list (|do [ebound (&/try-all% (&/|list (deref ?eid) - (fail "##4##")))] + (|do [ebound (&/try-all% (&/|list (|do [ebound (deref ?eid)] (return (&/V "lux;Some" ebound))) (return (&/V "lux;None" nil)))) - abound (&/try-all% (&/|list (|do [abound (&/try-all% (&/|list (deref ?aid) - (fail "##3##")))] + abound (&/try-all% (&/|list (|do [abound (deref ?aid)] (return (&/V "lux;Some" abound))) (return (&/V "lux;None" nil))))] (matchv ::M/objects [ebound abound] @@ -579,15 +575,13 @@ [["lux;VarT" ?id] _] (&/try-all% (&/|list (|do [_ (set-var ?id actual)] (return (&/T fixpoints nil))) - (|do [bound (&/try-all% (&/|list (deref ?id) - (fail "##1##")))] + (|do [bound (deref ?id)] (check* fixpoints bound actual)))) [_ ["lux;VarT" ?id]] (&/try-all% (&/|list (|do [_ (set-var ?id expected)] (return (&/T fixpoints nil))) - (|do [bound (&/try-all% (&/|list (deref ?id) - (fail "##2##")))] + (|do [bound (deref ?id)] (check* fixpoints expected bound)))) [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] -- cgit v1.2.3 From 0d365358ebc7d3e6f99c74641162d2024772698c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 7 May 2015 00:19:31 -0400 Subject: - Eliminated #eval-ctor from the HostState and now #seed is used for the same purpose. - Optimized some code a bit. --- source/lux.lux | 6 ++---- src/lux/base.clj | 14 +++----------- src/lux/compiler.clj | 42 +++++++++++++++++++++--------------------- src/lux/compiler/lambda.clj | 4 ++-- src/lux/lexer.clj | 30 +++++++++++++++--------------- src/lux/type.clj | 2 +- 6 files changed, 44 insertions(+), 54 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 5b59d788f..d2a309b5f 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -206,13 +206,11 @@ ## (deftype HostState ## (& #writer (^ org.objectweb.asm.ClassWriter) -## #loader (^ java.net.URLClassLoader) -## #eval-ctor Int)) +## #loader (^ java.net.URLClassLoader))) (def' HostState (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - (#Cons [["lux;eval-ctor" Int] - #Nil])])]))) + #Nil])]))) ## (deftype (DefData' m) ## (| #TypeD diff --git a/src/lux/base.clj b/src/lux/base.clj index 5292faffa..9ea255132 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -15,9 +15,8 @@ (def $NAME 3) ;; Host -(def $EVAL-CTOR 0) -(def $LOADER 1) -(def $WRITER 2) +(def $LOADER 0) +(def $WRITER 1) ;; CompilerState (def $ENVS 0) @@ -441,9 +440,7 @@ )) (defn host [_] - (R ;; "lux;eval-ctor" - 0 - ;; "lux;loader" + (R ;; "lux;loader" (-> (java.io.File. "./output/") .toURL vector into-array java.net.URLClassLoader.) ;; "lux;writer" (V "lux;None" nil))) @@ -465,11 +462,6 @@ +init-bindings+ )) -(def get-eval-ctor - (fn [state] - (return* (update$ $HOST #(update$ $EVAL-CTOR inc %) state) - (get$ $EVAL-CTOR (get$ $HOST state))))) - (def get-writer (fn [state] (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 209e29626..40bb3a710 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -315,27 +315,27 @@ (&&host/compile-jvm-class compile-expression ?package ?name ?super-class ?fields ?methods))) (defn ^:private eval! [expr] - (|do [eval-ctor &/get-eval-ctor - :let [class-name (str eval-ctor) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - class-name nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil) - (doto (.visitEnd))))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitCode *writer*)] - _ (compile-expression expr) - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC class-name "_eval" "Ljava/lang/Object;") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [bytecode (.toByteArray (doto =class - .visitEnd))] - _ (&&/save-class! class-name bytecode) - loader &/loader] + (|do [id &/gen-id + :let [class-name (str id) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + class-name nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil) + (doto (.visitEnd))))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitCode *writer*)] + _ (compile-expression expr) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/PUTSTATIC class-name "_eval" "Ljava/lang/Object;") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [bytecode (.toByteArray (doto =class + .visitEnd))] + _ (&&/save-class! class-name bytecode) + loader &/loader] (-> (.loadClass ^ClassLoader loader class-name) (.getField "_eval") (.get nil) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 65c7e58aa..625599617 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -63,7 +63,7 @@ $start (new Label) $end (new Label) _ (doto *writer* - (-> (.visitLocalVariable (str &&/local-prefix idx) (&host/->java-sig (&/V "lux;DataT" "java.lang.Object")) nil $start $end (+ 2 idx)) + (-> (.visitLocalVariable (str &&/local-prefix idx) "Ljava/lang/Object;" nil $start $end (+ 2 idx)) (->> (dotimes [idx num-locals]))) (.visitLabel $start))] ret (compile impl-body) @@ -92,7 +92,7 @@ (|do [:let [lambda-class (&host/location ?scope) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - lambda-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) + lambda-class nil "java/lang/Object" (into-array ["lux/Function"])) (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index f94a3d058..31258bc4b 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -36,18 +36,18 @@ (def ^:private lex-single-line-comment (|do [[_ [meta _]] (&reader/read-text "##") - [_ [_ comment]] (&reader/read-regex #"^(.*)$")] + [_ [_ comment]] (&reader/read-regex #"^(.*)$")] (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") - [meta comment] (&/try-all% (&/|list (|do [[_ [meta comment]] (&reader/read-regex #"(?is)^((?!#\().)*?(?=\)#)")] - (return comment)) - (|do [[_ [meta pre]] (&reader/read-regex #"(?is)^(.+?(?=#\())") - [_ inner] (lex-multi-line-comment nil) - [_ [_ post]] (&reader/read-regex #"(?is)^(.+?(?=\)#))")] - (return (str pre "#(" inner ")#" post))))) - _ (&reader/read-text ")#")] + [meta comment] (&/try-all% (&/|list (|do [[_ [meta comment]] (&reader/read-regex #"(?is)^((?!#\().)*?(?=\)#)")] + (return comment)) + (|do [[_ [meta pre]] (&reader/read-regex #"(?is)^(.+?(?=#\())") + [_ inner] (lex-multi-line-comment nil) + [_ [_ post]] (&reader/read-regex #"(?is)^(.+?(?=\)#))")] + (return (str pre "#(" inner ")#" post))))) + _ (&reader/read-text ")#")] (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) (def ^:private lex-comment @@ -65,17 +65,17 @@ (def ^:private lex-char (|do [[_ [meta _]] (&reader/read-text "#\"") - token (&/try-all% (&/|list (|do [[_ [_ escaped]] (&reader/read-regex #"^(\\.)")] - (escape-char escaped)) - (|do [[_ [_ char]] (&reader/read-regex #"^(.)")] - (return char)))) - _ (&reader/read-text "\"")] + token (&/try-all% (&/|list (|do [[_ [_ escaped]] (&reader/read-regex #"^(\\.)")] + (escape-char escaped)) + (|do [[_ [_ char]] (&reader/read-regex #"^(.)")] + (return char)))) + _ (&reader/read-text "\"")] (return (&/V "lux;Meta" (&/T meta (&/V "Char" token)))))) (def ^:private lex-text (|do [[_ [meta _]] (&reader/read-text "\"") - token (lex-text-body nil) - _ (&reader/read-text "\"")] + token (lex-text-body nil) + _ (&reader/read-text "\"")] (return (&/V "lux;Meta" (&/T meta (&/V "Text" token)))))) (def ^:private lex-ident diff --git a/src/lux/type.clj b/src/lux/type.clj index 2e9e85092..b2ea0ff0d 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -126,7 +126,7 @@ (&/V "lux;RecordT" (&/|list (&/T "lux;writer" (&/V "lux;DataT" "org.objectweb.asm.ClassWriter")) (&/T "lux;loader" (&/V "lux;DataT" "java.lang.ClassLoader")) - (&/T "lux;eval-ctor" Int)))) + ))) (def DefData* (fAll "DefData'" "" -- cgit v1.2.3 From ab7b946a980475cad1e58186ac8c929c7659f529 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 10 May 2015 10:37:06 -0400 Subject: - Now analysing function-application backwards. --- source/lux.lux | 682 +++++++++++++++++++++-------------------------- source/program.lux | 6 +- src/lux/analyser.clj | 75 +++--- src/lux/analyser/lux.clj | 77 +++--- src/lux/compiler.clj | 4 +- src/lux/compiler/lux.clj | 9 +- 6 files changed, 395 insertions(+), 458 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index d2a309b5f..26425e7b8 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -351,10 +351,9 @@ (lambda' _ tokens (case' tokens (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#Cons [($form (#Cons [($symbol ["" "case'"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil]))) + (return (#Cons [($form (#Cons [($symbol ["" "case'"]) + (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + #Nil])) _ (fail "Wrong syntax for let'"))))) @@ -365,36 +364,34 @@ (lambda' _ tokens (case' tokens (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) - (#Cons [(_meta (#Symbol ["" ""])) - (#Cons [arg - (#Cons [(case' args' - #Nil - body - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) + (#Cons [(_meta (#Symbol ["" ""])) + (#Cons [arg + (#Cons [(case' args' + #Nil + body + + _ + (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [(_meta (#Tuple args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) - (#Cons [(_meta (#Symbol self)) - (#Cons [arg - (#Cons [(case' args' - #Nil - body - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) + (#Cons [(_meta (#Symbol self)) + (#Cons [arg + (#Cons [(case' args' + #Nil + body + + _ + (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [(_meta (#Tuple args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) _ (fail "Wrong syntax for lambda"))))) @@ -403,118 +400,110 @@ (def' def_ (:' Macro (lambda_ [tokens] - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) - #Nil])]))) - - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) - #Nil])]))) - - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil]))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil]))) + (case' tokens + (#Cons [(#Meta [_ (#Tag ["" "export"])]) + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) + (#Cons [type + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [name + (#Cons [(_meta (#Tuple args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) + (#Cons [type + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [name + (#Cons [(_meta (#Tuple args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + #Nil])) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + #Nil])) - _ - (fail "Wrong syntax for def") - )))) + _ + (fail "Wrong syntax for def") + )))) (declare-macro' def_) (def_ #export (defmacro tokens) Macro (case' tokens (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def_"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])) - (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])])) - #Nil])]))) + (return (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($form (#Cons [name args])) + (#Cons [($symbol ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])) + (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])])) + #Nil])])) (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (:' SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def_"]) - (#Cons [($tag ["" "export"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])])) - (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])])) - #Nil])]))) + (return (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($tag ["" "export"]) + (#Cons [($form (#Cons [name args])) + (#Cons [($symbol ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])])) + (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])])) + #Nil])])) _ (fail "Wrong syntax for defmacro"))) (declare-macro' defmacro) (defmacro #export (comment tokens) - (return (:' SyntaxList #Nil))) + (return #Nil)) (defmacro (->' tokens) (case' tokens (#Cons [input (#Cons [output #Nil])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) + (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil])) (#Cons [input (#Cons [output others])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) + (#Cons [(_meta (#Tuple (#Cons [input + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) + #Nil])) _ (fail "Wrong syntax for ->'"))) @@ -523,24 +512,22 @@ (case' tokens (#Cons [(#Meta [_ (#Tuple #Nil)]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [body - #Nil]))) + (return (#Cons [body + #Nil])) (#Cons [(#Meta [_ (#Tuple (#Cons [(#Meta [_ (#Symbol ["" arg-name])]) other-args]))]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"])) - (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"])) - (#Cons [(_meta (#Text "")) - (#Cons [(_meta (#Text arg-name)) - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"])) - (#Cons [(_meta (#Tuple other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"])) + (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"])) + (#Cons [(_meta (#Text "")) + (#Cons [(_meta (#Text arg-name)) + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"])) + (#Cons [(_meta (#Tuple other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) + #Nil])) _ (fail "Wrong syntax for All'"))) @@ -549,11 +536,10 @@ (case' tokens (#Cons [(#Meta [_ (#Symbol ["" bound-name])]) #Nil]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"])) - (#Cons [(_meta (#Text bound-name)) - #Nil])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"])) + (#Cons [(_meta (#Text bound-name)) + #Nil])]))) + #Nil])) _ (fail "Wrong syntax for B'"))) @@ -564,13 +550,12 @@ (return tokens) (#Cons [x (#Cons [y xs])]) - (return (:' SyntaxList - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"])) - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"])) - (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil]))) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"])) + (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"])) + (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) + #Nil])) _ (fail "Wrong syntax for $'"))) @@ -591,34 +576,27 @@ (def_ #export (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) - (fold (:' (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda_ [tail head] - (#Cons [head tail]))) + (fold (lambda_ [tail head] (#Cons [head tail])) #Nil list)) (defmacro #export (list xs) - (return (:' SyntaxList - (#Cons [(fold (:' (->' Syntax Syntax Syntax) - (lambda_ [tail head] - (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"])) - (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])]))) - #Nil])]))))) - (_meta (#Tag ["lux" "Nil"])) - (reverse xs)) - #Nil])))) + (return (#Cons [(fold (lambda_ [tail head] + (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"])) + (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) + (_meta (#Tag ["lux" "Nil"])) + (reverse xs)) + #Nil]))) (defmacro #export (list& xs) (case' (reverse xs) (#Cons [last init]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax Syntax Syntax) - (lambda_ [tail head] - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) - (_meta (#Tuple (list head tail)))))))) - last - init)))) + (return (list (fold (lambda_ [tail head] + (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) + (_meta (#Tuple (list head tail))))))) + last + init))) _ (fail "Wrong syntax for list&"))) @@ -638,19 +616,16 @@ (fail "lambda requires a non-empty arguments tuple.") (#Cons [harg targs]) - (let' body' (fold (:' (->' Syntax Syntax Syntax) - (lambda_ [body' arg] - ($form (list ($symbol ["" "lambda'"]) - ($symbol ["" ""]) - arg - body')))) - body - (reverse targs)) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "lambda'"]) - ($symbol name) - harg - body'))))))) + (return (list ($form (list ($symbol ["" "lambda'"]) + ($symbol name) + harg + (fold (lambda_ [body' arg] + ($form (list ($symbol ["" "lambda'"]) + ($symbol ["" ""]) + arg + body'))) + body + (reverse targs))))))) _ (fail "Wrong syntax for lambda")))) @@ -660,43 +635,39 @@ (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))) - ($form (list ($symbol ["" "export'"]) name))))) + (return (list ($form (list ($symbol ["" "def'"]) + name + ($form (list ($symbol ["" ":'"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))) + ($form (list ($symbol ["" "export'"]) name)))) (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - body)))) - ($form (list ($symbol ["" "export'"]) name))))) + (return (list ($form (list ($symbol ["" "def'"]) + name + ($form (list ($symbol ["" ":'"]) + type + body)))) + ($form (list ($symbol ["" "export'"]) name)))) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body))))))))) + (return (list ($form (list ($symbol ["" "def'"]) + name + ($form (list ($symbol ["" ":'"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))))) (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (:' SyntaxList - (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) type body))))))) + (return (list ($form (list ($symbol ["" "def'"]) + name + ($form (list ($symbol ["" ":'"]) type body)))))) _ (fail "Wrong syntax for def") @@ -715,20 +686,19 @@ (defmacro #export (let tokens) (case' tokens (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (case' binding - [label value] - (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))) - body - (fold (:' (->' ($' List (#TupleT (list Syntax Syntax))) (#TupleT (list Syntax Syntax)) - ($' List (#TupleT (list Syntax Syntax)))) - (lambda [tail head] - (#Cons [head tail]))) - #Nil - (as-pairs bindings)))))) + (return (list (fold (:' (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (case' binding + [label value] + (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))) + body + (fold (:' (->' ($' List (#TupleT (list Syntax Syntax))) (#TupleT (list Syntax Syntax)) + ($' List (#TupleT (list Syntax Syntax)))) + (lambda [tail head] + (#Cons [head tail]))) + #Nil + (as-pairs bindings))))) _ (fail "Wrong syntax for let"))) @@ -792,12 +762,9 @@ (defmacro #export ($ tokens) (case' tokens (#Cons [op (#Cons [init args])]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax Syntax Syntax) - (lambda [a1 a2] - ($form (list op a1 a2)))) - init - args)))) + (return (list (fold (lambda [a1 a2] ($form (list op a1 a2))) + init + args))) _ (fail "Wrong syntax for $"))) @@ -882,8 +849,7 @@ (defmacro (`' tokens) (case' tokens (#Cons [template #Nil]) - (return (:' SyntaxList - (list (untemplate "" template)))) + (return (list (untemplate "" template))) _ (fail "Wrong syntax for `'"))) @@ -891,17 +857,15 @@ (defmacro #export (|> tokens) (case' tokens (#Cons [init apps]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax Syntax Syntax) - (lambda [acc app] - (case' app - (#Meta [_ (#Form parts)]) - ($form (list:++ parts (list acc))) - - _ - (`' ((~ app) (~ acc)))))) - init - apps)))) + (return (list (fold (lambda [acc app] + (case' app + (#Meta [_ (#Form parts)]) + ($form (list:++ parts (list acc))) + + _ + (`' ((~ app) (~ acc))))) + init + apps))) _ (fail "Wrong syntax for |>"))) @@ -909,10 +873,9 @@ (defmacro #export (if tokens) (case' tokens (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (:' SyntaxList - (list (`' (case' (~ test) - true (~ then) - false (~ else)))))) + (return (list (`' (case' (~ test) + true (~ then) + false (~ else))))) _ (fail "Wrong syntax for if"))) @@ -969,8 +932,7 @@ (defmacro #export (^ tokens) (case' tokens (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) - (return (:' SyntaxList - (list (`' (#;DataT (~ (_meta (#Text class-name)))))))) + (return (list (`' (#;DataT (~ (_meta (#Text class-name))))))) _ (fail "Wrong syntax for ^"))) @@ -978,19 +940,15 @@ (defmacro #export (-> tokens) (case' (reverse tokens) (#Cons [output inputs]) - (return (:' SyntaxList - (list (fold (:' (->' Syntax Syntax Syntax) - (lambda [o i] - (`' (#;LambdaT [(~ i) (~ o)])))) - output - inputs)))) + (return (list (fold (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) + output + inputs))) _ (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) - (return (:' SyntaxList - (list (`' (#;TupleT (;list (~@ tokens)))))))) + (return (list (`' (#;TupleT (;list (~@ tokens))))))) (defmacro (do tokens) (case' tokens @@ -1004,15 +962,14 @@ _ (`' (;bind (lambda' (~ ($symbol ["" ""])) - (~ var) - (~ body')) - (~ value))))))) + (~ var) + (~ body')) + (~ value))))))) body (reverse (as-pairs bindings)))] - (return (:' SyntaxList - (list (`' (case' (~ monad) - {#;return ;return #;bind ;bind} - (~ body'))))))) + (return (list (`' (case' (~ monad) + {#;return ;return #;bind ;bind} + (~ body')))))) _ (fail "Wrong syntax for do"))) @@ -1028,13 +985,13 @@ (let [{#;return ;return #;bind _} m] (case' xs #Nil - (;return (:' List #Nil)) + (;return #Nil) (#Cons [x xs']) (do m [y (f x) ys (map% m f xs')] - (;return (:' List (#Cons [y ys])))) + (;return (#Cons [y ys]))) ))) (def__ #export (. f g) @@ -1241,19 +1198,16 @@ (#Some idents) (case' idents #Nil - (return (:' SyntaxList (list body))) + (return (list body)) (#Cons [harg targs]) (let [replacements (map (:' (-> Text (, Text Syntax)) (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) (list& self-ident idents)) - body' (fold (:' (-> Syntax Text Syntax) - (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) + body' (fold (lambda [body' arg'] (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))) (replace-syntax replacements body) (reverse targs))] - (return (:' SyntaxList - (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) + (return (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))) #None (fail "'All' arguments must be symbols.")) @@ -1313,13 +1267,12 @@ (do Lux:Monad [current-module get-module-name] (let [[module name] ident] - (:' ($' Lux ($' Maybe Macro)) - (lambda [state] - (case' state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (#Right [state (find-macro' modules current-module module name)]))))))) + (lambda [state] + (case' state + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (#Right [state (find-macro' modules current-module module name)])))))) (def__ (list:join xs) (All [a] @@ -1353,17 +1306,17 @@ (#Meta [_ (#Tag ident)]) (do Lux:Monad [ident (normalize ident)] - (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (;,)])))) + (;return (`' [(~ ($text (ident->text ident))) (;,)]))) (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))]) (do Lux:Monad [ident (normalize ident)] - (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) _ (fail "Wrong syntax for |")))) tokens)] - (;return (:' SyntaxList (list (`' (#;VariantT (;list (~@ pairs))))))))) + (;return (list (`' (#;VariantT (;list (~@ pairs)))))))) (defmacro #export (& tokens) (if (not (multiple? 2 (length tokens))) @@ -1376,12 +1329,12 @@ [(#Meta [_ (#Tag ident)]) value] (do Lux:Monad [ident (normalize ident)] - (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) _ (fail "Wrong syntax for &")))) (as-pairs tokens))] - (;return (:' SyntaxList (list (`' (#;RecordT (;list (~@ pairs)))))))))) + (;return (list (`' (#;RecordT (;list (~@ pairs))))))))) (def__ #export (->text x) (-> (^ java.lang.Object) Text) @@ -1446,31 +1399,31 @@ (do Lux:Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] - (case' (:' ($' Maybe Macro) ?macro) + (case' ?macro (#Some macro) (do Lux:Monad [expansion (macro args) expansion' (map% Lux:Monad macro-expand expansion)] - (;return (:' SyntaxList (list:join expansion')))) + (;return (list:join expansion'))) #None (do Lux:Monad [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] - (;return (:' SyntaxList (list ($form (list:join parts')))))))) + (;return (list ($form (list:join parts'))))))) (#Meta [_ (#Form (#Cons [harg targs]))]) (do Lux:Monad [harg+ (macro-expand harg) targs+ (map% Lux:Monad macro-expand targs)] - (;return (:' SyntaxList (list ($form (list:++ harg+ (list:join (:' ($' List ($' List Syntax)) targs+)))))))) + (;return (list ($form (list:++ harg+ (list:join targs+)))))) (#Meta [_ (#Tuple members)]) (do Lux:Monad [members' (map% Lux:Monad macro-expand members)] - (;return (:' SyntaxList (list ($tuple (list:join members')))))) + (;return (list ($tuple (list:join members'))))) _ - (return (:' SyntaxList (list syntax))))) + (return (list syntax)))) (def__ (walk-type type) (-> Syntax Syntax) @@ -1482,9 +1435,7 @@ ($tuple (map walk-type members)) (#Meta [_ (#Form (#Cons [type-fn args]))]) - (fold (:' (-> Syntax Syntax Syntax) - (lambda [type-fn arg] - (`' (#;AppT [(~ type-fn) (~ arg)])))) + (fold (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) (walk-type type-fn) (map walk-type args)) @@ -1496,9 +1447,9 @@ (#Cons [type #Nil]) (do Lux:Monad [type+ (macro-expand type)] - (case' (:' SyntaxList type+) + (case' type+ (#Cons [type' #Nil]) - (;return (:' SyntaxList (list (walk-type type')))) + (;return (list (walk-type type'))) _ (fail "type`: The expansion of the type-syntax had to yield a single element."))) @@ -1509,7 +1460,7 @@ (defmacro #export (: tokens) (case' tokens (#Cons [type (#Cons [value #Nil])]) - (return (:' SyntaxList (list (`' (:' (;type` (~ type)) (~ value)))))) + (return (list (`' (:' (;type` (~ type)) (~ value))))) _ (fail "Wrong syntax for :"))) @@ -1517,7 +1468,7 @@ (defmacro #export (:! tokens) (case' tokens (#Cons [type (#Cons [value #Nil])]) - (return (:' SyntaxList (list (`' (:!' (;type` (~ type)) (~ value)))))) + (return (list (`' (:!' (;type` (~ type)) (~ value))))) _ (fail "Wrong syntax for :!"))) @@ -1539,9 +1490,7 @@ (#Some [($symbol name) args type]) _ - #None)) - ] - ## (return (: (List Syntax) #Nil)) + #None))] (case' parts (#Some [name args type]) (let [with-export (: (List Syntax) @@ -1555,9 +1504,8 @@ _ (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (: (List Syntax) - (list& (`' (def' (~ name) (;type` (~ type')))) - with-export)))) + (return (list& (`' (def' (~ name) (;type` (~ type')))) + with-export))) #None (fail "Wrong syntax for deftype")) @@ -1570,8 +1518,7 @@ (case' tokens (#Cons [value #Nil]) (let [blank ($symbol ["" ""])] - (return (: (List Syntax) - (list (`' (lambda' (~ blank) (~ blank) (~ value))))))) + (return (list (`' (lambda' (~ blank) (~ blank) (~ value)))))) _ (fail "Wrong syntax for io"))) @@ -1580,12 +1527,9 @@ (case' (reverse tokens) (#Cons [value actions]) (let [dummy ($symbol ["" ""])] - (return (:' SyntaxList - (list (fold (:' (-> Syntax Syntax Syntax) - (lambda [post pre] - (`' (case' (~ pre) (~ dummy) (~ post))))) - value - actions))))) + (return (list (fold (lambda [post pre] (`' (case' (~ pre) (~ dummy) (~ post)))) + value + actions)))) _ (fail "Wrong syntax for exec"))) @@ -1630,10 +1574,10 @@ #None body'))] - (return (: (List Syntax) (list& (`' (def' (~ name) (~ body''))) - (if export? - (list (`' (export' (~ name)))) - #Nil))))) + (return (list& (`' (def' (~ name) (~ body''))) + (if export? + (list (`' (export' (~ name)))) + #Nil)))) #None (fail "Wrong syntax for def")))) @@ -1655,16 +1599,14 @@ (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) macro-args]))]) (do Lux:Monad [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args))) - expansions (map% Lux:Monad expander (as-pairs (: (List Syntax) expansion)))] - (;return (list:join (: (List (List (, Syntax Syntax))) expansions)))) + expansions (map% Lux:Monad expander (as-pairs expansion))] + (;return (list:join expansions))) _ - (;return (: (List (, Syntax Syntax)) (list branch))))))) + (;return (list branch)))))) (as-pairs branches))] - (;return (: (List Syntax) - (list (`' (case' (~ value) - (~@ (|> (: (List (List (, Syntax Syntax))) expansions) list:join (map rejoin-pair) list:join)) - )))))) + (;return (list (`' (case' (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) _ (fail "Wrong syntax for case"))) @@ -1674,9 +1616,9 @@ (#Cons [body (#Cons [pattern #Nil])]) (do Lux:Monad [pattern+ (macro-expand pattern)] - (case (: (List Syntax) pattern+) + (case pattern+ (#Cons [pattern' #Nil]) - (;return (: (List Syntax) (list pattern' body))) + (;return (list pattern' body)) _ (fail "\\ can only expand to 1 pattern."))) @@ -1694,10 +1636,8 @@ _ (do Lux:Monad [patterns' (map% Lux:Monad macro-expand patterns)] - (;return (: (List Syntax) (list:join (map (: (-> Syntax (List Syntax)) - (lambda [pattern] - (list pattern body))) - (list:join (: (List (List Syntax)) patterns')))))))) + (;return (list:join (map (lambda [pattern] (list pattern body)) + (list:join patterns')))))) _ (fail "Wrong syntax for \\or"))) @@ -1718,8 +1658,7 @@ [module-name get-module-name] (case tokens (\ (list template)) - (;return (: (List Syntax) - (list (untemplate (: Text module-name) template)))) + (;return (list (untemplate module-name template))) _ (fail "Wrong syntax for `")))) @@ -1739,7 +1678,7 @@ (-> Syntax (Lux Syntax)) (do Lux:Monad [token+ (macro-expand token)] - (case (: (List Syntax) token+) + (case token+ (\ (list token')) (;return token') @@ -1760,14 +1699,13 @@ _ (fail "Signatures require typed members!")))) - (: (List Syntax) tokens'))] - (;return (: (List Syntax) - (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) - (lambda [pair] - (let [[name type] pair] - (`' [(~ (|> name ident->text $text)) - (~ type)])))) - (: (List (, Ident Syntax)) members))))))))))) + tokens')] + (;return (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) + (lambda [pair] + (let [[name type] pair] + (`' [(~ (|> name ident->text $text)) + (~ type)])))) + members))))))))) (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1789,17 +1727,17 @@ #None))] (case ?parts (#Some [name args sigs]) - (let [sigs' (: Syntax (case args - #Nil - (`' (;sig (~@ sigs))) + (let [sigs' (: Syntax + (case args + #Nil + (`' (;sig (~@ sigs))) - _ - (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (: (List Syntax) - (list& (`' (def' (~ name) (~ sigs'))) - (if export? - (list (`' (export' (~ name)))) - #Nil))))) + _ + (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] + (return (list& (`' (def' (~ name) (~ sigs'))) + (if export? + (list (`' (export' (~ name)))) + #Nil)))) #None (fail "Wrong syntax for defsig")))) @@ -1818,9 +1756,8 @@ _ (fail "Structures require defined members!")))) - (: (List Syntax) tokens'))] - (;return (: (List Syntax) - (list ($record members)))))) + tokens')] + (;return (list ($record members))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1842,17 +1779,17 @@ #None))] (case ?parts (#Some [name args type defs]) - (let [defs' (: Syntax (case args - #Nil - (`' (;struct (~@ defs))) + (let [defs' (: Syntax + (case args + #Nil + (`' (;struct (~@ defs))) - _ - (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (: (List Syntax) - (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (export' (~ name)))) - #Nil))))) + _ + (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] + (return (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (export' (~ name)))) + #Nil)))) #None (fail "Wrong syntax for defsig")))) @@ -1901,11 +1838,9 @@ [(defmacro #export ( tokens) (case (reverse tokens) (\ (list& last init)) - (return (: (List Syntax) - (list (fold (: (-> Syntax Syntax Syntax) - (lambda [post pre] (`
))) - last - init)))) + (return (list (fold (lambda [post pre] (` )) + last + init))) _ (fail )))] @@ -1944,10 +1879,9 @@ (list name) (list))))) lux)] - (#Right [state (map (: (-> Text Syntax) - (lambda [name] - (` ((~ ($symbol ["" "def'"])) (~ ($symbol ["" name])) - (~ ($symbol ["lux" name])))))) + (#Right [state (map (lambda [name] + (` ((~ ($symbol ["" "def'"])) (~ ($symbol ["" name])) + (~ ($symbol ["lux" name]))))) (list:join to-alias))])) #None diff --git a/source/program.lux b/source/program.lux index 22bbad2d5..2bbf3fd4f 100644 --- a/source/program.lux +++ b/source/program.lux @@ -13,6 +13,6 @@ (jvm-program _ (exec (println "Hello, world!") - (println ($ text:++ "2 + 2 = " (->text (int:+ 2 2)))) - (println (->text (using Int:Ord - (< 5 10)))))) + (|> (int:+ 2 2) ->text ($ text:++ "2 + 2 = ") println) + (println (->text (using Int:Ord + (< 5 10)))))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 8fad07dfa..939a3ea0a 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -26,44 +26,45 @@ ["lux;Nil" _]]]]]]]]] (&/T catch+ ?finally-body))) -(defn ^:private aba1 [analyse eval! exo-type token] - (matchv ::M/objects [token] - ;; Standard special forms - [["lux;Meta" [meta ["lux;Bool" ?value]]]] - (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - - [["lux;Meta" [meta ["lux;Int" ?value]]]] - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - - [["lux;Meta" [meta ["lux;Real" ?value]]]] - (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - - [["lux;Meta" [meta ["lux;Char" ?value]]]] - (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - - [["lux;Meta" [meta ["lux;Text" ?value]]]] - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - - [["lux;Meta" [meta ["lux;Tuple" ?elems]]]] - (&&lux/analyse-tuple analyse exo-type ?elems) +(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;Tuple" (|list))))] + (defn ^:private aba1 [analyse eval! exo-type token] + (matchv ::M/objects [token] + ;; Standard special forms + [["lux;Meta" [meta ["lux;Bool" ?value]]]] + (|do [_ (&type/check exo-type &type/Bool)] + (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) + + [["lux;Meta" [meta ["lux;Int" ?value]]]] + (|do [_ (&type/check exo-type &type/Int)] + (return (&/|list (&/T (&/V "int" ?value) exo-type)))) + + [["lux;Meta" [meta ["lux;Real" ?value]]]] + (|do [_ (&type/check exo-type &type/Real)] + (return (&/|list (&/T (&/V "real" ?value) exo-type)))) + + [["lux;Meta" [meta ["lux;Char" ?value]]]] + (|do [_ (&type/check exo-type &type/Char)] + (return (&/|list (&/T (&/V "char" ?value) exo-type)))) + + [["lux;Meta" [meta ["lux;Text" ?value]]]] + (|do [_ (&type/check exo-type &type/Text)] + (return (&/|list (&/T (&/V "text" ?value) exo-type)))) + + [["lux;Meta" [meta ["lux;Tuple" ?elems]]]] + (&&lux/analyse-tuple analyse exo-type ?elems) + + [["lux;Meta" [meta ["lux;Record" ?elems]]]] + (&&lux/analyse-record analyse exo-type ?elems) + + [["lux;Meta" [meta ["lux;Tag" ?ident]]]] + (&&lux/analyse-variant analyse exo-type ?ident unit) + + [["lux;Meta" [meta ["lux;Symbol" [_ "jvm-null"]]]]] + (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) - [["lux;Meta" [meta ["lux;Record" ?elems]]]] - (&&lux/analyse-record analyse exo-type ?elems) - - [["lux;Meta" [meta ["lux;Tag" ?ident]]]] - (&&lux/analyse-variant analyse exo-type ?ident (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;Tuple" (|list))))) - - [["lux;Meta" [meta ["lux;Symbol" [_ "jvm-null"]]]]] - (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) - - [_] - (fail "") - )) + [_] + (fail "") + ))) (defn ^:private aba2 [analyse eval! exo-type token] (matchv ::M/objects [token] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index df87a08b6..e4237d8dd 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -172,42 +172,39 @@ ))) )) -(defn ^:private analyse-apply* [analyse exo-type =fn ?args] - (matchv ::M/objects [=fn] - [[?fun-expr ?fun-type]] - (matchv ::M/objects [?args] - [["lux;Nil" _]] - (|do [_ (&type/check exo-type ?fun-type)] - (return =fn)) - - [["lux;Cons" [?arg ?args*]]] - (|do [?fun-type* (&type/actual-type ?fun-type)] - (matchv ::M/objects [?fun-type*] - [["lux;AllT" _]] - (&type/with-var - (fn [$var] - (|do [type* (&type/apply-type ?fun-type* $var) - output (analyse-apply* analyse exo-type (&/T ?fun-expr type*) ?args)] - (matchv ::M/objects [output $var] - [[?expr* ?type*] ["lux;VarT" ?id]] - (|do [? (&type/bound? ?id) - _ (if ? - (return nil) - (|do [ex &type/existential] - (&type/set-var ?id ex))) - type** (&type/clean $var ?type*)] - (return (&/T ?expr* type**))) - )))) - - [["lux;LambdaT" [?input-t ?output-t]]] - (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)] - (analyse-apply* analyse exo-type (&/T (&/V "apply" (&/T =fn =arg)) - ?output-t) - ?args*)) +(defn ^:private analyse-apply* [analyse exo-type fun-type args] + (matchv ::M/objects [args] + [["lux;Nil" _]] + (|do [_ (&type/check exo-type fun-type)] + (return (&/T (&/|list) fun-type))) + + [["lux;Cons" [?arg ?args*]]] + (|do [?fun-type* (&type/actual-type fun-type)] + (matchv ::M/objects [?fun-type*] + [["lux;AllT" _]] + (&type/with-var + (fn [$var] + (|do [type* (&type/apply-type ?fun-type* $var) + [?args** ?type**] (analyse-apply* analyse exo-type type* args)] + (matchv ::M/objects [$var] + [["lux;VarT" ?id]] + (|do [? (&type/bound? ?id) + _ (if ? + (return nil) + (|do [ex &type/existential] + (&type/set-var ?id ex))) + type*** (&type/clean $var ?type**)] + (return (&/T ?args** type***))) + )))) + + [["lux;LambdaT" [?input-t ?output-t]]] + (|do [[=args ?output-t*] (analyse-apply* analyse exo-type ?output-t ?args*) + =arg (&&/analyse-1 analyse ?input-t ?arg)] + (return (&/T (&/|cons =arg =args) ?output-t*))) - [_] - (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) - ))) + [_] + (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) + )) (defn analyse-apply [analyse exo-type =fn ?args] (|do [loader &/loader] @@ -222,12 +219,14 @@ (&/flat-map% (partial analyse exo-type) macro-expansion)) [_] - (|do [output (analyse-apply* analyse exo-type =fn ?args)] - (return (&/|list output))))) + (|do [[=args =app-type] (analyse-apply* analyse exo-type =fn-type ?args)] + (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) + =app-type)))))) [_] - (|do [output (analyse-apply* analyse exo-type =fn ?args)] - (return (&/|list output)))) + (|do [[=args =app-type] (analyse-apply* analyse exo-type =fn-type ?args)] + (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) + =app-type))))) ))) (defn analyse-case [analyse exo-type ?value ?branches] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 40bb3a710..6739c5529 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -60,8 +60,8 @@ [["lux;Global" [?owner-class ?name]]] (&&lux/compile-global compile-expression ?type ?owner-class ?name) - [["apply" [?fn ?arg]]] - (&&lux/compile-apply compile-expression ?type ?fn ?arg) + [["apply" [?fn ?args]]] + (&&lux/compile-apply compile-expression ?type ?fn ?args) [["variant" [?tag ?members]]] (&&lux/compile-variant compile-expression ?type ?tag ?members) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index cf4a65f04..2c5073a4d 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -117,11 +117,14 @@ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (&/|list ?owner-class ?name))) "_datum" "Ljava/lang/Object;")]] (return nil))) -(defn compile-apply [compile *type* ?fn ?arg] +(defn compile-apply [compile *type* ?fn ?args] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?fn) - _ (compile ?arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature)]] + _ (&/map% (fn [?arg] + (|do [_ (compile ?arg) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature)]] + (return nil))) + ?args)] (return nil))) (defn compile-def [compile ?name ?body ?def-data] -- cgit v1.2.3 From 8dc736e2a383fe964d63dda6b885d41cabc6261c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 10 May 2015 15:04:36 -0400 Subject: - Switched to the new prefix convention for both lux's special forms and the host's. - Made a few optimizations to speed-up the now slowed-down compiler. --- source/lux.lux | 2317 ++++++++++++++++++++++--------------------- source/program.lux | 10 +- src/lux/analyser.clj | 202 ++-- src/lux/analyser/host.clj | 2 +- src/lux/analyser/lux.clj | 81 +- src/lux/analyser/module.clj | 30 +- src/lux/base.clj | 6 + src/lux/compiler.clj | 15 +- src/lux/reader.clj | 4 +- src/lux/type.clj | 109 +- 10 files changed, 1407 insertions(+), 1369 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 26425e7b8..f2a6f70da 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -7,53 +7,53 @@ ## You must not remove this notice, or any other, from this software. ## First things first, must define functions -(jvm-interface Function - (:' (-> [java.lang.Object] java.lang.Object) +(_jvm_interface Function + (: (-> [java.lang.Object] java.lang.Object) apply)) ## Basic types -(def' Bool (#DataT "java.lang.Boolean")) -(export' Bool) +(_lux_def Bool (#DataT "java.lang.Boolean")) +(_lux_export Bool) -(def' Int (#DataT "java.lang.Long")) -(export' Int) +(_lux_def Int (#DataT "java.lang.Long")) +(_lux_export Int) -(def' Real (#DataT "java.lang.Double")) -(export' Real) +(_lux_def Real (#DataT "java.lang.Double")) +(_lux_export Real) -(def' Char (#DataT "java.lang.Character")) -(export' Char) +(_lux_def Char (#DataT "java.lang.Character")) +(_lux_export Char) -(def' Text (#DataT "java.lang.String")) -(export' Text) +(_lux_def Text (#DataT "java.lang.String")) +(_lux_export Text) -(def' Void (#VariantT #Nil)) -(export' Void) +(_lux_def Void (#VariantT #Nil)) +(_lux_export Void) -(def' Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) -(export' Ident) +(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) +(_lux_export Ident) ## (deftype (List a) ## (| #Nil ## (#Cons (, a (List a))))) -(def' List - (#AllT [#None "List" "a" - (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] - (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) - #Nil])]))] - #Nil])]))])) -(export' List) +(_lux_def List + (#AllT [#None "List" "a" + (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] + (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") + (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) + #Nil])]))] + #Nil])]))])) +(_lux_export List) ## (deftype (Maybe a) ## (| #None ## (#Some a))) -(def' Maybe - (#AllT [#None "Maybe" "a" - (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] - (#Cons [["lux;Some" (#BoundT "a")] - #Nil])]))])) -(export' Maybe) +(_lux_def Maybe + (#AllT [#None "Maybe" "a" + (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] + (#Cons [["lux;Some" (#BoundT "a")] + #Nil])]))])) +(_lux_export Maybe) ## (deftype #rec Type ## (| (#DataT Text) @@ -65,70 +65,70 @@ ## (#VarT Int) ## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) ## (#AppT (, Type Type)))) -(def' Type - (case' (#AppT [(#BoundT "Type") (#BoundT "_")]) - Type - (case' (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) - TypeEnv - (#AppT [(#AllT [#None "Type" "_" - (#VariantT (#Cons [["lux;DataT" Text] - (#Cons [["lux;TupleT" (#AppT [List Type])] - (#Cons [["lux;VariantT" TypeEnv] - (#Cons [["lux;RecordT" TypeEnv] - (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;BoundT" Text] - (#Cons [["lux;VarT" Int] - (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] - (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;ExT" Int] - #Nil])])])])])])])])])]))]) - Void])))) -(export' Type) +(_lux_def Type + (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) + Type + (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) + TypeEnv + (#AppT [(#AllT [#None "Type" "_" + (#VariantT (#Cons [["lux;DataT" Text] + (#Cons [["lux;TupleT" (#AppT [List Type])] + (#Cons [["lux;VariantT" TypeEnv] + (#Cons [["lux;RecordT" TypeEnv] + (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;BoundT" Text] + (#Cons [["lux;VarT" Int] + (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] + (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;ExT" Int] + #Nil])])])])])])])])])]))]) + Void])))) +(_lux_export Type) ## (deftype (Bindings k v) ## (& #counter Int ## #mappings (List (, k v)))) -(def' Bindings - (#AllT [#None "Bindings" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;counter" Int] - (#Cons [["lux;mappings" (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))])] - #Nil])]))])])) +(_lux_def Bindings + (#AllT [#None "Bindings" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;counter" Int] + (#Cons [["lux;mappings" (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))])] + #Nil])]))])])) ## (deftype (Env k v) ## (& #name Text ## #inner-closures Int ## #locals (Bindings k v) ## #closure (Bindings k v))) -(def' Env - (#AllT [#None "Env" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;name" Text] - (#Cons [["lux;inner-closures" Int] - (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - #Nil])])])]))])])) +(_lux_def Env + (#AllT [#None "Env" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;name" Text] + (#Cons [["lux;inner-closures" Int] + (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + #Nil])])])]))])])) ## (deftype Cursor ## (, Text Int Int)) -(def' Cursor - (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) +(_lux_def Cursor + (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) ## (deftype (Meta m v) ## (| (#Meta (, m v)))) -(def' Meta - (#AllT [#None "Meta" "m" - (#AllT [#None "" "v" - (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") - (#Cons [(#BoundT "v") - #Nil])]))] - #Nil]))])])) -(export' Meta) +(_lux_def Meta + (#AllT [#None "Meta" "m" + (#AllT [#None "" "v" + (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") + (#Cons [(#BoundT "v") + #Nil])]))] + #Nil]))])])) +(_lux_export Meta) ## (deftype (Syntax' w) ## (| (#Bool Bool) @@ -141,98 +141,98 @@ ## (#Form (List (w (Syntax' w)))) ## (#Tuple (List (w (Syntax' w)))) ## (#Record (List (, (w (Syntax' w)) (w (Syntax' w))))))) -(def' Syntax' - (case' (#AppT [(#BoundT "w") - (#AppT [(#BoundT "Syntax'") - (#BoundT "w")])]) - Syntax - (case' (#AppT [List Syntax]) - SyntaxList - (#AllT [#None "Syntax'" "w" - (#VariantT (#Cons [["lux;Bool" Bool] - (#Cons [["lux;Int" Int] - (#Cons [["lux;Real" Real] - (#Cons [["lux;Char" Char] - (#Cons [["lux;Text" Text] - (#Cons [["lux;Symbol" Ident] - (#Cons [["lux;Tag" Ident] - (#Cons [["lux;Form" SyntaxList] - (#Cons [["lux;Tuple" SyntaxList] - (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] - #Nil]) - ])])])])])])])])]) - )])))) -(export' Syntax') +(_lux_def Syntax' + (_lux_case (#AppT [(#BoundT "w") + (#AppT [(#BoundT "Syntax'") + (#BoundT "w")])]) + Syntax + (_lux_case (#AppT [List Syntax]) + SyntaxList + (#AllT [#None "Syntax'" "w" + (#VariantT (#Cons [["lux;Bool" Bool] + (#Cons [["lux;Int" Int] + (#Cons [["lux;Real" Real] + (#Cons [["lux;Char" Char] + (#Cons [["lux;Text" Text] + (#Cons [["lux;Symbol" Ident] + (#Cons [["lux;Tag" Ident] + (#Cons [["lux;Form" SyntaxList] + (#Cons [["lux;Tuple" SyntaxList] + (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] + #Nil]) + ])])])])])])])])]) + )])))) +(_lux_export Syntax') ## (deftype Syntax ## (Meta Cursor (Syntax' (Meta Cursor)))) -(def' Syntax - (case' (#AppT [Meta Cursor]) - w - (#AppT [w (#AppT [Syntax' w])]))) -(export' Syntax) +(_lux_def Syntax + (_lux_case (#AppT [Meta Cursor]) + w + (#AppT [w (#AppT [Syntax' w])]))) +(_lux_export Syntax) -(def' SyntaxList (#AppT [List Syntax])) +(_lux_def SyntaxList (#AppT [List Syntax])) ## (deftype (Either l r) ## (| (#Left l) ## (#Right r))) -(def' Either - (#AllT [#None "_" "l" - (#AllT [#None "" "r" - (#VariantT (#Cons [["lux;Left" (#BoundT "l")] - (#Cons [["lux;Right" (#BoundT "r")] - #Nil])]))])])) -(export' Either) +(_lux_def Either + (#AllT [#None "_" "l" + (#AllT [#None "" "r" + (#VariantT (#Cons [["lux;Left" (#BoundT "l")] + (#Cons [["lux;Right" (#BoundT "r")] + #Nil])]))])])) +(_lux_export Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) -(def' StateE - (#AllT [#None "StateE" "s" - (#AllT [#None "" "a" - (#LambdaT [(#BoundT "s") - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [(#BoundT "s") - (#Cons [(#BoundT "a") - #Nil])]))])])])])) - -## (def' Reader +(_lux_def StateE + (#AllT [#None "StateE" "s" + (#AllT [#None "" "a" + (#LambdaT [(#BoundT "s") + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [(#BoundT "s") + (#Cons [(#BoundT "a") + #Nil])]))])])])])) + +## (deftype Reader ## (List (Meta Cursor Text))) -(def' Reader - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])])) -(export' Reader) +(_lux_def Reader + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])])) +(_lux_export Reader) ## (deftype HostState ## (& #writer (^ org.objectweb.asm.ClassWriter) ## #loader (^ java.net.URLClassLoader))) -(def' HostState - (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] - (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - #Nil])]))) +(_lux_def HostState + (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] + (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] + #Nil])]))) ## (deftype (DefData' m) ## (| #TypeD ## (#ValueD Type) ## (#MacroD m) ## (#AliasD Ident))) -(def' DefData' - (#AllT [#None "DefData'" "" - (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] - (#Cons [["lux;ValueD" Type] - (#Cons [["lux;MacroD" (#BoundT "")] - (#Cons [["lux;AliasD" Ident] - #Nil])])])]))])) +(_lux_def DefData' + (#AllT [#None "DefData'" "" + (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] + (#Cons [["lux;ValueD" Type] + (#Cons [["lux;MacroD" (#BoundT "")] + (#Cons [["lux;AliasD" Ident] + #Nil])])])]))])) ## (deftype LuxVar ## (| (#Local Int) ## (#Global Ident))) -(def' LuxVar - (#VariantT (#Cons [["lux;Local" Int] - (#Cons [["lux;Global" Ident] - #Nil])]))) -(export' LuxVar) +(_lux_def LuxVar + (#VariantT (#Cons [["lux;Local" Int] + (#Cons [["lux;Global" Ident] + #Nil])]))) +(_lux_export LuxVar) ## (deftype #rec CompilerState ## (& #source Reader @@ -241,324 +241,324 @@ ## #envs (List (Env Text (, LuxVar Type))) ## #types (Bindings Int Type) ## #host HostState)) -(def' CompilerState - (#AppT [(#AllT [#None "CompilerState" "" - (#RecordT (#Cons [["lux;source" Reader] - (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") - (#BoundT "")])]) - SyntaxList])])]) - #Nil])])) - #Nil])]))]) - #Nil])]))])] - (#Cons [["lux;module-aliases" (#AppT [List Void])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - (#Cons [["lux;seed" Int] - #Nil])])])])])])]))]) - Void])) -(export' CompilerState) +(_lux_def CompilerState + (#AppT [(#AllT [#None "CompilerState" "" + (#RecordT (#Cons [["lux;source" Reader] + (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") + (#BoundT "")])]) + SyntaxList])])]) + #Nil])])) + #Nil])]))]) + #Nil])]))])] + (#Cons [["lux;module-aliases" (#AppT [List Void])] + (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] + (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] + (#Cons [["lux;host" HostState] + (#Cons [["lux;seed" Int] + #Nil])])])])])])]))]) + Void])) +(_lux_export CompilerState) ## (deftype Macro ## (-> (List Syntax) (StateE CompilerState (List Syntax)))) -(def' Macro - (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE CompilerState]) - SyntaxList])])) -(export' Macro) +(_lux_def Macro + (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE CompilerState]) + SyntaxList])])) +(_lux_export Macro) ## Base functions & macros ## (def (_meta data) ## (-> (Syntax' (Meta Cursor)) Syntax) ## (#Meta [["" -1 -1] data])) -(def' _meta - (:' (#LambdaT [(#AppT [Syntax' - (#AppT [Meta Cursor])]) - Syntax]) - (lambda' _ data - (#Meta [["" -1 -1] data])))) +(_lux_def _meta + (_lux_: (#LambdaT [(#AppT [Syntax' + (#AppT [Meta Cursor])]) + Syntax]) + (_lux_lambda _ data + (#Meta [["" -1 -1] data])))) ## (def (return x) ## (All [a] ## (-> a CompilerState ## (Either Text (, CompilerState a)))) ## ...) -(def' return - (:' (#AllT [#None "" "a" - (#LambdaT [(#BoundT "a") - (#LambdaT [CompilerState - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (lambda' _ val - (lambda' _ state - (#Right [state val]))))) +(_lux_def return + (_lux_: (#AllT [#None "" "a" + (#LambdaT [(#BoundT "a") + (#LambdaT [CompilerState + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [CompilerState + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ val + (_lux_lambda _ state + (#Right [state val]))))) ## (def (fail msg) ## (All [a] ## (-> Text CompilerState ## (Either Text (, CompilerState a)))) ## ...) -(def' fail - (:' (#AllT [#None "" "a" - (#LambdaT [Text - (#LambdaT [CompilerState - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (lambda' _ msg - (lambda' _ state - (#Left msg))))) - -(def' $text - (:' (#LambdaT [Text Syntax]) - (lambda' _ text - (_meta (#Text text))))) - -(def' $symbol - (:' (#LambdaT [Ident Syntax]) - (lambda' _ ident - (_meta (#Symbol ident))))) - -(def' $tag - (:' (#LambdaT [Ident Syntax]) - (lambda' _ ident - (_meta (#Tag ident))))) - -(def' $form - (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) - (lambda' _ tokens - (_meta (#Form tokens))))) - -(def' $tuple - (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) - (lambda' _ tokens - (_meta (#Tuple tokens))))) - -(def' $record - (:' (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) - (lambda' _ tokens - (_meta (#Record tokens))))) - -(def' let' - (:' Macro - (lambda' _ tokens - (case' tokens - (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (#Cons [($form (#Cons [($symbol ["" "case'"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil])) - - _ - (fail "Wrong syntax for let'"))))) -(declare-macro' let') - -(def' lambda_ - (:' Macro - (lambda' _ tokens - (case' tokens - (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) - (#Cons [(_meta (#Symbol ["" ""])) - (#Cons [arg - (#Cons [(case' args' - #Nil - body - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) - (#Cons [(_meta (#Symbol self)) - (#Cons [arg - (#Cons [(case' args' - #Nil - body - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - _ - (fail "Wrong syntax for lambda"))))) -(declare-macro' lambda_) - -(def' def_ - (:' Macro - (lambda_ [tokens] - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil])) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil])) - - _ - (fail "Wrong syntax for def") - )))) -(declare-macro' def_) +(_lux_def fail + (_lux_: (#AllT [#None "" "a" + (#LambdaT [Text + (#LambdaT [CompilerState + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [CompilerState + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ msg + (_lux_lambda _ state + (#Left msg))))) + +(_lux_def $text + (_lux_: (#LambdaT [Text Syntax]) + (_lux_lambda _ text + (_meta (#Text text))))) + +(_lux_def $symbol + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#Symbol ident))))) + +(_lux_def $tag + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#Tag ident))))) + +(_lux_def $form + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#Form tokens))))) + +(_lux_def $tuple + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#Tuple tokens))))) + +(_lux_def $record + (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_lambda _ tokens + (_meta (#Record tokens))))) + +(_lux_def let' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) + (return (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) + (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + #Nil])) + + _ + (fail "Wrong syntax for let'"))))) +(_lux_declare-macro let') + +(_lux_def lambda_ + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_lambda"])) + (#Cons [(_meta (#Symbol ["" ""])) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [(_meta (#Tuple args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) + + (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_lambda"])) + (#Cons [(_meta (#Symbol self)) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [(_meta (#Tuple args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) + + _ + (fail "Wrong syntax for lambda"))))) +(_lux_declare-macro lambda_) + +(_lux_def def_ + (_lux_: Macro + (lambda_ [tokens] + (_lux_case tokens + (#Cons [(#Meta [_ (#Tag ["" "export"])]) + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [name + (#Cons [(_meta (#Tuple args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#Form (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#Form (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) + (#Cons [name + (#Cons [(_meta (#Tuple args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + #Nil])) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + #Nil])) + + _ + (fail "Wrong syntax for def") + )))) +(_lux_declare-macro def_) (def_ #export (defmacro tokens) Macro - (case' tokens - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (#Cons [($form (#Cons [($symbol ["lux" "def_"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])) - (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])])) - #Nil])])) - - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (#Cons [($form (#Cons [($symbol ["lux" "def_"]) - (#Cons [($tag ["" "export"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])])) - (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])])) - #Nil])])) - - _ - (fail "Wrong syntax for defmacro"))) -(declare-macro' defmacro) + (_lux_case tokens + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) + (return (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($form (#Cons [name args])) + (#Cons [($symbol ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])) + (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])])) + + (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])])]) + (return (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($tag ["" "export"]) + (#Cons [($form (#Cons [name args])) + (#Cons [($symbol ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])])) + (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])])) + + _ + (fail "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) (defmacro #export (comment tokens) (return #Nil)) (defmacro (->' tokens) - (case' tokens - (#Cons [input (#Cons [output #Nil])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil])) - - (#Cons [input (#Cons [output others])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for ->'"))) + (_lux_case tokens + (#Cons [input (#Cons [output #Nil])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) + (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil])) + + (#Cons [input (#Cons [output others])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) + (#Cons [(_meta (#Tuple (#Cons [input + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for ->'"))) (defmacro (All' tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tuple #Nil)]) - (#Cons [body #Nil])]) - (return (#Cons [body - #Nil])) - - (#Cons [(#Meta [_ (#Tuple (#Cons [(#Meta [_ (#Symbol ["" arg-name])]) other-args]))]) - (#Cons [body #Nil])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"])) - (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"])) - (#Cons [(_meta (#Text "")) - (#Cons [(_meta (#Text arg-name)) - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"])) - (#Cons [(_meta (#Tuple other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for All'"))) + (_lux_case tokens + (#Cons [(#Meta [_ (#Tuple #Nil)]) + (#Cons [body #Nil])]) + (return (#Cons [body + #Nil])) + + (#Cons [(#Meta [_ (#Tuple (#Cons [(#Meta [_ (#Symbol ["" arg-name])]) other-args]))]) + (#Cons [body #Nil])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"])) + (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"])) + (#Cons [(_meta (#Text "")) + (#Cons [(_meta (#Text arg-name)) + (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"])) + (#Cons [(_meta (#Tuple other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for All'"))) (defmacro (B' tokens) - (case' tokens - (#Cons [(#Meta [_ (#Symbol ["" bound-name])]) - #Nil]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"])) - (#Cons [(_meta (#Text bound-name)) - #Nil])]))) - #Nil])) + (_lux_case tokens + (#Cons [(#Meta [_ (#Symbol ["" bound-name])]) + #Nil]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"])) + (#Cons [(_meta (#Text bound-name)) + #Nil])]))) + #Nil])) - _ - (fail "Wrong syntax for B'"))) + _ + (fail "Wrong syntax for B'"))) (defmacro ($' tokens) - (case' tokens - (#Cons [x #Nil]) - (return tokens) + (_lux_case tokens + (#Cons [x #Nil]) + (return tokens) - (#Cons [x (#Cons [y xs])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"])) - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"])) - (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil])) + (#Cons [x (#Cons [y xs])]) + (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"])) + (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"])) + (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) + #Nil])) - _ - (fail "Wrong syntax for $'"))) + _ + (fail "Wrong syntax for $'"))) (def_ #export (fold f init xs) (All' [a b] @@ -566,12 +566,12 @@ (B' a) ($' List (B' b)) (B' a))) - (case' xs - #Nil - init + (_lux_case xs + #Nil + init - (#Cons [x xs']) - (fold f (f init x) xs'))) + (#Cons [x xs']) + (fold f (f init x) xs'))) (def_ #export (reverse list) (All' [a] @@ -590,149 +590,146 @@ #Nil]))) (defmacro #export (list& xs) - (case' (reverse xs) - (#Cons [last init]) - (return (list (fold (lambda_ [tail head] - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) - (_meta (#Tuple (list head tail))))))) - last - init))) + (_lux_case (reverse xs) + (#Cons [last init]) + (return (list (fold (lambda_ [tail head] + (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) + (_meta (#Tuple (list head tail))))))) + last + init))) - _ - (fail "Wrong syntax for list&"))) + _ + (fail "Wrong syntax for list&"))) (defmacro #export (lambda tokens) - (let' [name tokens'] (:' (#TupleT (list Ident ($' List Syntax))) - (case' tokens - (#Cons [(#Meta [_ (#Symbol name)]) tokens']) - [name tokens'] - - _ - [["" ""] tokens])) - (case' tokens' - (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) - (case' args - #Nil - (fail "lambda requires a non-empty arguments tuple.") - - (#Cons [harg targs]) - (return (list ($form (list ($symbol ["" "lambda'"]) - ($symbol name) - harg - (fold (lambda_ [body' arg] - ($form (list ($symbol ["" "lambda'"]) - ($symbol ["" ""]) - arg - body'))) - body - (reverse targs))))))) + (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) + (_lux_case tokens + (#Cons [(#Meta [_ (#Symbol name)]) tokens']) + [name tokens'] - _ - (fail "Wrong syntax for lambda")))) + _ + [["" ""] tokens])) + (_lux_case tokens' + (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) + (_lux_case args + #Nil + (fail "lambda requires a non-empty arguments tuple.") + + (#Cons [harg targs]) + (return (list ($form (list ($symbol ["" "_lux_lambda"]) + ($symbol name) + harg + (fold (lambda_ [body' arg] + ($form (list ($symbol ["" "_lux_lambda"]) + ($symbol ["" ""]) + arg + body'))) + body + (reverse targs))))))) + + _ + (fail "Wrong syntax for lambda")))) (defmacro (def__ tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))) - ($form (list ($symbol ["" "export'"]) name)))) - - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - body)))) - ($form (list ($symbol ["" "export'"]) name)))) - - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (list ($form (list ($symbol ["" "def'"]) - name - ($form (list ($symbol ["" ":'"]) type body)))))) - - _ - (fail "Wrong syntax for def") - )) + (_lux_case tokens + (#Cons [(#Meta [_ (#Tag ["" "export"])]) + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))) + ($form (list ($symbol ["" "_lux_export"]) name)))) + + (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + body)))) + ($form (list ($symbol ["" "_lux_export"]) name)))) + + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))))) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) type body)))))) + + _ + (fail "Wrong syntax for def") + )) (def__ (as-pairs xs) (All' [a] (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) - (case' xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) + (_lux_case xs + (#Cons [x (#Cons [y xs'])]) + (#Cons [[x y] (as-pairs xs')]) - _ - #Nil)) + _ + #Nil)) (defmacro #export (let tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) - (return (list (fold (:' (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (case' binding - [label value] - (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))) - body - (fold (:' (->' ($' List (#TupleT (list Syntax Syntax))) (#TupleT (list Syntax Syntax)) - ($' List (#TupleT (list Syntax Syntax)))) - (lambda [tail head] - (#Cons [head tail]))) - #Nil - (as-pairs bindings))))) + (_lux_case tokens + (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) + (return (list (fold (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (_lux_case binding + [label value] + (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))) + body + (fold (lambda [tail head] (#Cons [head tail])) + #Nil + (as-pairs bindings))))) - _ - (fail "Wrong syntax for let"))) + _ + (fail "Wrong syntax for let"))) (def__ #export (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) - (case' xs - #Nil - #Nil + (_lux_case xs + #Nil + #Nil - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) + (#Cons [x xs']) + (#Cons [(f x) (map f xs')]))) (def__ #export (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) - (case' xs - #Nil - false + (_lux_case xs + #Nil + false - (#Cons [x xs']) - (case' (p x) - true true - false (any? p xs')))) + (#Cons [x xs']) + (_lux_case (p x) + true true + false (any? p xs')))) (def__ (spliced? token) (->' Syntax Bool) - (case' token - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [_ #Nil])]))]) - true + (_lux_case token + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [_ #Nil])]))]) + true - _ - false)) + _ + false)) (def__ (wrap-meta content) (->' Syntax Syntax) @@ -742,143 +739,142 @@ (def__ (untemplate-list tokens) (->' ($' List Syntax) Syntax) - (case' tokens - #Nil - (_meta (#Tag ["lux" "Nil"])) + (_lux_case tokens + #Nil + (_meta (#Tag ["lux" "Nil"])) - (#Cons [token tokens']) - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) - (_meta (#Tuple (list token (untemplate-list tokens'))))))))) + (#Cons [token tokens']) + (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) + (_meta (#Tuple (list token (untemplate-list tokens'))))))))) (def__ (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) - (case' xs - (#Cons [x xs']) - (#Cons [x (list:++ xs' ys)]) + (_lux_case xs + (#Cons [x xs']) + (#Cons [x (list:++ xs' ys)]) - #Nil - ys)) + #Nil + ys)) (defmacro #export ($ tokens) - (case' tokens - (#Cons [op (#Cons [init args])]) - (return (list (fold (lambda [a1 a2] ($form (list op a1 a2))) - init - args))) - - _ - (fail "Wrong syntax for $"))) + (_lux_case tokens + (#Cons [op (#Cons [init args])]) + (return (list (fold (lambda [a1 a2] ($form (list op a1 a2))) + init + args))) + + _ + (fail "Wrong syntax for $"))) (def__ (splice untemplate tag elems) (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) - (case' (any? spliced? elems) - true - (let [elems' (map (:' (->' Syntax Syntax) - (lambda [elem] - (case' elem - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced + (_lux_case (any? spliced? elems) + true + (let [elems' (map (lambda [elem] + (_lux_case elem + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced - _ - ($form (list ($symbol ["" ":'"]) - ($symbol ["lux" "SyntaxList"]) - ($form (list ($symbol ["lux" "list"]) (untemplate elem)))))))) - elems)] - (wrap-meta ($form (list tag - ($form (list& ($symbol ["lux" "$"]) - ($symbol ["lux" "list:++"]) - elems')))))) - - false - (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) + _ + ($form (list ($symbol ["" "_lux_:"]) + ($symbol ["lux" "SyntaxList"]) + ($form (list ($symbol ["lux" "list"]) (untemplate elem))))))) + elems)] + (wrap-meta ($form (list tag + ($form (list& ($symbol ["lux" "$"]) + ($symbol ["lux" "list:++"]) + elems')))))) + + false + (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) (def__ (untemplate subst token) (->' Text Syntax Syntax) - (case' token - (#Meta [_ (#Bool value)]) - (wrap-meta ($form (list ($tag ["lux" "Bool"]) (_meta (#Bool value))))) + (_lux_case token + (#Meta [_ (#Bool value)]) + (wrap-meta ($form (list ($tag ["lux" "Bool"]) (_meta (#Bool value))))) - (#Meta [_ (#Int value)]) - (wrap-meta ($form (list ($tag ["lux" "Int"]) (_meta (#Int value))))) + (#Meta [_ (#Int value)]) + (wrap-meta ($form (list ($tag ["lux" "Int"]) (_meta (#Int value))))) - (#Meta [_ (#Real value)]) - (wrap-meta ($form (list ($tag ["lux" "Real"]) (_meta (#Real value))))) + (#Meta [_ (#Real value)]) + (wrap-meta ($form (list ($tag ["lux" "Real"]) (_meta (#Real value))))) - (#Meta [_ (#Char value)]) - (wrap-meta ($form (list ($tag ["lux" "Char"]) (_meta (#Char value))))) + (#Meta [_ (#Char value)]) + (wrap-meta ($form (list ($tag ["lux" "Char"]) (_meta (#Char value))))) - (#Meta [_ (#Text value)]) - (wrap-meta ($form (list ($tag ["lux" "Text"]) (_meta (#Text value))))) + (#Meta [_ (#Text value)]) + (wrap-meta ($form (list ($tag ["lux" "Text"]) (_meta (#Text value))))) - (#Meta [_ (#Tag [module name])]) - (let [module' (case' module - "" - subst + (#Meta [_ (#Tag [module name])]) + (let [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "Tag"]) ($tuple (list ($text module') ($text name))))))) + _ + module)] + (wrap-meta ($form (list ($tag ["lux" "Tag"]) ($tuple (list ($text module') ($text name))))))) - (#Meta [_ (#Symbol [module name])]) - (let [module' (case' module - "" - subst + (#Meta [_ (#Symbol [module name])]) + (let [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "Symbol"]) ($tuple (list ($text module') ($text name))))))) + _ + module)] + (wrap-meta ($form (list ($tag ["lux" "Symbol"]) ($tuple (list ($text module') ($text name))))))) - (#Meta [_ (#Tuple elems)]) - (splice (untemplate subst) ($tag ["lux" "Tuple"]) elems) + (#Meta [_ (#Tuple elems)]) + (splice (untemplate subst) ($tag ["lux" "Tuple"]) elems) - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))]) - unquoted + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))]) + unquoted - (#Meta [_ (#Form elems)]) - (splice (untemplate subst) ($tag ["lux" "Form"]) elems) + (#Meta [_ (#Form elems)]) + (splice (untemplate subst) ($tag ["lux" "Form"]) elems) - (#Meta [_ (#Record fields)]) - (wrap-meta ($form (list ($tag ["lux" "Record"]) - (untemplate-list (map (:' (->' (#TupleT (list Syntax Syntax)) Syntax) - (lambda [kv] - (let [[k v] kv] - ($tuple (list (untemplate subst k) (untemplate subst v)))))) - fields))))) - )) + (#Meta [_ (#Record fields)]) + (wrap-meta ($form (list ($tag ["lux" "Record"]) + (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) + (lambda [kv] + (let [[k v] kv] + ($tuple (list (untemplate subst k) (untemplate subst v)))))) + fields))))) + )) (defmacro (`' tokens) - (case' tokens - (#Cons [template #Nil]) - (return (list (untemplate "" template))) + (_lux_case tokens + (#Cons [template #Nil]) + (return (list (untemplate "" template))) - _ - (fail "Wrong syntax for `'"))) + _ + (fail "Wrong syntax for `'"))) (defmacro #export (|> tokens) - (case' tokens - (#Cons [init apps]) - (return (list (fold (lambda [acc app] - (case' app - (#Meta [_ (#Form parts)]) - ($form (list:++ parts (list acc))) + (_lux_case tokens + (#Cons [init apps]) + (return (list (fold (lambda [acc app] + (_lux_case app + (#Meta [_ (#Form parts)]) + ($form (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc))))) - init - apps))) + _ + (`' ((~ app) (~ acc))))) + init + apps))) - _ - (fail "Wrong syntax for |>"))) + _ + (fail "Wrong syntax for |>"))) (defmacro #export (if tokens) - (case' tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (list (`' (case' (~ test) - true (~ then) - false (~ else))))) + (_lux_case tokens + (#Cons [test (#Cons [then (#Cons [else #Nil])])]) + (return (list (`' (_lux_case (~ test) + true (~ then) + false (~ else))))) - _ - (fail "Wrong syntax for if"))) + _ + (fail "Wrong syntax for if"))) ## (deftype (Lux a) ## (-> CompilerState (Either Text (, CompilerState a)))) @@ -908,71 +904,71 @@ #lux;bind (lambda [f ma] - (case' ma - #None #None - (#Some a) (f a)))}) + (_lux_case ma + #None #None + (#Some a) (f a)))}) (def__ Lux:Monad ($' Monad Lux) {#lux;return - (lambda return [x] - (lambda [state] - (#Right [state x]))) + (lambda [x] + (lambda [state] + (#Right [state x]))) #lux;bind (lambda [f ma] (lambda [state] - (case' (ma state) - (#Left msg) - (#Left msg) + (_lux_case (ma state) + (#Left msg) + (#Left msg) - (#Right [state' a]) - (f a state'))))}) + (#Right [state' a]) + (f a state'))))}) (defmacro #export (^ tokens) - (case' tokens - (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) - (return (list (`' (#;DataT (~ (_meta (#Text class-name))))))) + (_lux_case tokens + (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) + (return (list (`' (#;DataT (~ (_meta (#Text class-name))))))) - _ - (fail "Wrong syntax for ^"))) + _ + (fail "Wrong syntax for ^"))) (defmacro #export (-> tokens) - (case' (reverse tokens) - (#Cons [output inputs]) - (return (list (fold (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) - output - inputs))) - - _ - (fail "Wrong syntax for ->"))) + (_lux_case (reverse tokens) + (#Cons [output inputs]) + (return (list (fold (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) + output + inputs))) + + _ + (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) (return (list (`' (#;TupleT (;list (~@ tokens))))))) (defmacro (do tokens) - (case' tokens - (#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) - (let [body' (fold (:' (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (case' var - (#Meta [_ (#Tag ["" "let"])]) - (`' (;let (~ value) (~ body'))) - - _ - (`' (;bind (lambda' (~ ($symbol ["" ""])) - (~ var) - (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (return (list (`' (case' (~ monad) - {#;return ;return #;bind ;bind} - (~ body')))))) - - _ - (fail "Wrong syntax for do"))) + (_lux_case tokens + (#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) + (let [body' (fold (_lux_: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (_lux_case var + (#Meta [_ (#Tag ["" "let"])]) + (`' (;let (~ value) (~ body'))) + + _ + (`' (;bind (_lux_lambda (~ ($symbol ["" ""])) + (~ var) + (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (return (list (`' (_lux_case (~ monad) + {#;return ;return #;bind ;bind} + (~ body')))))) + + _ + (fail "Wrong syntax for do"))) (def__ (map% m f xs) ## (All [m a b] @@ -983,16 +979,16 @@ ($' List (B' a)) ($' (B' m) ($' List (B' b))))) (let [{#;return ;return #;bind _} m] - (case' xs - #Nil - (;return #Nil) - - (#Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;return (#Cons [y ys]))) - ))) + (_lux_case xs + #Nil + (;return #Nil) + + (#Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;return (#Cons [y ys]))) + ))) (def__ #export (. f g) (All' [a b c] @@ -1002,21 +998,21 @@ (def__ (get-ident x) (-> Syntax ($' Maybe Text)) - (case' x - (#Meta [_ (#Symbol ["" sname])]) - (#Some sname) + (_lux_case x + (#Meta [_ (#Symbol ["" sname])]) + (#Some sname) - _ - #None)) + _ + #None)) (def__ (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) - (case' tuple - (#Meta [_ (#Tuple members)]) - (#Some members) + (_lux_case tuple + (#Meta [_ (#Tuple members)]) + (#Some members) - _ - #None)) + _ + #None)) (def__ RepEnv Type @@ -1024,97 +1020,97 @@ (def__ (make-env xs ys) (-> ($' List Text) ($' List Syntax) RepEnv) - (case' (:' (, ($' List Text) ($' List Syntax)) - [xs ys]) - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (make-env xs' ys')]) + (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) + [xs ys]) + [(#Cons [x xs']) (#Cons [y ys'])] + (#Cons [[x y] (make-env xs' ys')]) - _ - #Nil)) + _ + #Nil)) (def__ (text:= x y) (-> Text Text Bool) - (jvm-invokevirtual java.lang.Object equals [java.lang.Object] - x [y])) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y])) (def__ (get-rep key env) (-> Text RepEnv ($' Maybe Syntax)) - (case' env - #Nil - #None + (_lux_case env + #Nil + #None - (#Cons [[k v] env']) - (if (text:= k key) - (#Some v) - (get-rep key env')))) + (#Cons [[k v] env']) + (if (text:= k key) + (#Some v) + (get-rep key env')))) (def__ (apply-template env template) (-> RepEnv Syntax Syntax) - (case' template - (#Meta [_ (#Symbol ["" sname])]) - (case' (get-rep sname env) - (#Some subst) - subst + (_lux_case template + (#Meta [_ (#Symbol ["" sname])]) + (_lux_case (get-rep sname env) + (#Some subst) + subst - _ - template) + _ + template) - (#Meta [_ (#Tuple elems)]) - ($tuple (map (apply-template env) elems)) + (#Meta [_ (#Tuple elems)]) + ($tuple (map (apply-template env) elems)) - (#Meta [_ (#Form elems)]) - ($form (map (apply-template env) elems)) + (#Meta [_ (#Form elems)]) + ($form (map (apply-template env) elems)) - (#Meta [_ (#Record members)]) - ($record (map (:' (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [kv] - (let [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) - members)) + (#Meta [_ (#Record members)]) + ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [kv] + (let [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) + members)) - _ - template)) + _ + template)) (def__ (join-map f xs) (All' [a b] (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) - (case' xs - #Nil - #Nil - - (#Cons [x xs']) - (list:++ (f x) (join-map f xs')))) - -(defmacro (do-template tokens) - (case' tokens - (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [(#Meta [_ (#Tuple templates)]) data])]) - (case' (:' (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(map% Maybe:Monad get-ident bindings) - (map% Maybe:Monad tuple->list data)]) - [(#Some bindings') (#Some data')] - (let [apply (:' (-> RepEnv ($' List Syntax)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - return)) + (_lux_case xs + #Nil + #Nil + + (#Cons [x xs']) + (list:++ (f x) (join-map f xs')))) + +(defmacro #export (do-template tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [(#Meta [_ (#Tuple templates)]) data])]) + (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) + [(map% Maybe:Monad get-ident bindings) + (map% Maybe:Monad tuple->list data)]) + [(#Some bindings') (#Some data')] + (let [apply (_lux_: (-> RepEnv ($' List Syntax)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + return)) - _ - (fail "All the do-template bindigns must be symbols.")) + _ + (fail "All the do-template bindigns must be symbols.")) - _ - (fail "Wrong syntax for do-template"))) + _ + (fail "Wrong syntax for do-template"))) (do-template [ ] [(def__ #export ( x y) (-> Bool) ( x y))] - [int:= jvm-leq Int] - [int:> jvm-lgt Int] - [int:< jvm-llt Int] - [real:= jvm-deq Real] - [real:> jvm-dgt Real] - [real:< jvm-dlt Real] + [int:= _jvm_leq Int] + [int:> _jvm_lgt Int] + [int:< _jvm_llt Int] + [real:= _jvm_deq Real] + [real:> _jvm_dgt Real] + [real:< _jvm_dlt Real] ) (do-template [ ] @@ -1122,16 +1118,16 @@ (-> ) ( x y))] - [int:+ jvm-ladd Int] - [int:- jvm-lsub Int] - [int:* jvm-lmul Int] - [int:/ jvm-ldiv Int] - [int:% jvm-lrem Int] - [real:+ jvm-dadd Real] - [real:- jvm-dsub Real] - [real:* jvm-dmul Real] - [real:/ jvm-ddiv Real] - [real:% jvm-drem Real] + [int:+ _jvm_ladd Int] + [int:- _jvm_lsub Int] + [int:* _jvm_lmul Int] + [int:/ _jvm_ldiv Int] + [int:% _jvm_lrem Int] + [real:+ _jvm_dadd Real] + [real:- _jvm_dsub Real] + [real:* _jvm_dmul Real] + [real:/ _jvm_ddiv Real] + [real:% _jvm_drem Real] ) (def__ (multiple? div n) @@ -1148,8 +1144,8 @@ (def__ #export (text:++ x y) (-> Text Text Text) - (jvm-invokevirtual java.lang.String concat [java.lang.String] - x [y])) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y])) (def__ (ident->text ident) (-> Ident Text) @@ -1158,88 +1154,88 @@ (def__ (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) - (case' syntax - (#Meta [_ (#Symbol ["" name])]) - (case' (get-rep name reps) - (#Some replacement) - replacement - - #None - syntax) - - (#Meta [_ (#Form parts)]) - (#Meta [_ (#Form (map (replace-syntax reps) parts))]) - - (#Meta [_ (#Tuple members)]) - (#Meta [_ (#Tuple (map (replace-syntax reps) members))]) - - (#Meta [_ (#Record slots)]) - (#Meta [_ (#Record (map (:' (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))]) - - _ - syntax) + (_lux_case syntax + (#Meta [_ (#Symbol ["" name])]) + (_lux_case (get-rep name reps) + (#Some replacement) + replacement + + #None + syntax) + + (#Meta [_ (#Form parts)]) + (#Meta [_ (#Form (map (replace-syntax reps) parts))]) + + (#Meta [_ (#Tuple members)]) + (#Meta [_ (#Tuple (map (replace-syntax reps) members))]) + + (#Meta [_ (#Record slots)]) + (#Meta [_ (#Record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[k v] slot] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))]) + + _ + syntax) ) (defmacro #export (All tokens) - (let [[self-ident tokens'] (:' (, Text SyntaxList) - (case' tokens - (#Cons [(#Meta [_ (#Symbol ["" self-ident])]) tokens']) - [self-ident tokens'] - - _ - ["" tokens]))] - (case' tokens' - (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) - (case' (map% Maybe:Monad get-ident args) - (#Some idents) - (case' idents - #Nil - (return (list body)) - - (#Cons [harg targs]) - (let [replacements (map (:' (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) - (list& self-ident idents)) - body' (fold (lambda [body' arg'] (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))) - (replace-syntax replacements body) - (reverse targs))] - (return (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))) - - #None - (fail "'All' arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) + (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) + (_lux_case tokens + (#Cons [(#Meta [_ (#Symbol ["" self-ident])]) tokens']) + [self-ident tokens'] + + _ + ["" tokens]))] + (_lux_case tokens' + (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) + (_lux_case (map% Maybe:Monad get-ident args) + (#Some idents) + (_lux_case idents + #Nil + (return (list body)) + + (#Cons [harg targs]) + (let [replacements (map (_lux_: (-> Text (, Text Syntax)) + (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) + (list& self-ident idents)) + body' (fold (lambda [body' arg'] (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))) + (replace-syntax replacements body) + (reverse targs))] + (return (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))) + + #None + (fail "'All' arguments must be symbols.")) + + _ + (fail "Wrong syntax for All")) )) (def__ (get k plist) (All [a] (-> Text ($' List (, Text a)) ($' Maybe a))) - (case' plist - (#Cons [[k' v] plist']) - (if (text:= k k') - (#Some v) - (get k plist')) + (_lux_case plist + (#Cons [[k' v] plist']) + (if (text:= k k') + (#Some v) + (get k plist')) - #Nil - #None)) + #Nil + #None)) (def__ #export (get-module-name state) ($' Lux Text) - (case' state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (case' (reverse envs) - #Nil - (#Left "Can't get the module name without a module!") + (_lux_case state + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (_lux_case (reverse envs) + #Nil + (#Left "Can't get the module name without a module!") - (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) - (#Right [state module-name])))) + (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Right [state module-name])))) (def__ (find-macro' modules current-module module name) (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE CompilerState ($' List Syntax))))))))) @@ -1248,19 +1244,19 @@ (do Maybe:Monad [bindings (get module modules) gdef (get name bindings)] - (case' (:' (, Bool ($' DefData' Macro)) gdef) - [exported? (#MacroD macro')] - (if exported? - (#Some macro') - (if (text:= module current-module) - (#Some macro') - #None)) - - [_ (#AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) - - _ - #None))) + (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) + [exported? (#MacroD macro')] + (if exported? + (#Some macro') + (if (text:= module current-module) + (#Some macro') + #None)) + + [_ (#AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #None))) (def__ #export (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) @@ -1268,53 +1264,63 @@ [current-module get-module-name] (let [[module name] ident] (lambda [state] - (case' state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (#Right [state (find-macro' modules current-module module name)])))))) + (_lux_case state + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (#Right [state (find-macro' modules current-module module name)])))))) (def__ (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) (fold list:++ #Nil xs)) +## (def__ #export (normalize ident) +## (-> Ident ($' Lux Ident)) +## (_lux_case ident +## ["" name] +## (do Lux:Monad +## [module-name get-module-name] +## (;return (: Ident [module-name name]))) + +## _ +## (return ident))) (def__ #export (normalize ident state) (-> Ident ($' Lux Ident)) - (case' ident - ["" name] - (case' state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (case' (reverse envs) - #Nil - (#Left "Can't normalize Ident without a global environment.") + (_lux_case ident + ["" name] + (_lux_case state + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (_lux_case (reverse envs) + #Nil + (#Left "Can't normalize Ident without a global environment.") - (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) - (#Right [state [prefix name]]))) - - _ - (#Right [state ident]))) + (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) + (#Right [state [prefix name]]))) + + _ + (#Right [state ident]))) (defmacro #export (| tokens) (do Lux:Monad [pairs (map% Lux:Monad - (:' (-> Syntax ($' Lux Syntax)) - (lambda [token] - (case' token - (#Meta [_ (#Tag ident)]) - (do Lux:Monad - [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (;,)]))) - - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))]) - (do Lux:Monad - [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for |")))) + (_lux_: (-> Syntax ($' Lux Syntax)) + (lambda [token] + (_lux_case token + (#Meta [_ (#Tag ident)]) + (do Lux:Monad + [ident (normalize ident)] + (;return (`' [(~ ($text (ident->text ident))) (;,)]))) + + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))]) + (do Lux:Monad + [ident (normalize ident)] + (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) + + _ + (fail "Wrong syntax for |")))) tokens)] (;return (list (`' (#;VariantT (;list (~@ pairs)))))))) @@ -1323,264 +1329,267 @@ (fail "& expects an even number of arguments.") (do Lux:Monad [pairs (map% Lux:Monad - (:' (-> (, Syntax Syntax) ($' Lux Syntax)) - (lambda [pair] - (case' pair - [(#Meta [_ (#Tag ident)]) value] - (do Lux:Monad - [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for &")))) + (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) + (lambda [pair] + (_lux_case pair + [(#Meta [_ (#Tag ident)]) value] + (do Lux:Monad + [ident (normalize ident)] + (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) + + _ + (fail "Wrong syntax for &")))) (as-pairs tokens))] (;return (list (`' (#;RecordT (;list (~@ pairs))))))))) (def__ #export (->text x) (-> (^ java.lang.Object) Text) - (jvm-invokevirtual java.lang.Object toString [] x [])) + (_jvm_invokevirtual java.lang.Object toString [] x [])) (def__ #export (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) - (case' xs - #Nil - xs + (_lux_case xs + #Nil + xs - (#Cons [x #Nil]) - xs + (#Cons [x #Nil]) + xs - (#Cons [x xs']) - (list& x sep (interpose sep xs')))) + (#Cons [x xs']) + (list& x sep (interpose sep xs')))) (def__ #export (syntax:show syntax) (-> Syntax Text) - (case' syntax - (#Meta [_ (#Bool value)]) - (->text value) + (_lux_case syntax + (#Meta [_ (#Bool value)]) + (->text value) - (#Meta [_ (#Int value)]) - (->text value) + (#Meta [_ (#Int value)]) + (->text value) - (#Meta [_ (#Real value)]) - (->text value) + (#Meta [_ (#Real value)]) + (->text value) - (#Meta [_ (#Char value)]) - ($ text:++ "#\"" (->text value) "\"") + (#Meta [_ (#Char value)]) + ($ text:++ "#\"" (->text value) "\"") - (#Meta [_ (#Text value)]) - value + (#Meta [_ (#Text value)]) + value - (#Meta [_ (#Symbol ident)]) - (ident->text ident) + (#Meta [_ (#Symbol ident)]) + (ident->text ident) - (#Meta [_ (#Tag ident)]) - (text:++ "#" (ident->text ident)) + (#Meta [_ (#Tag ident)]) + (text:++ "#" (ident->text ident)) - (#Meta [_ (#Tuple members)]) - ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") + (#Meta [_ (#Tuple members)]) + ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") - (#Meta [_ (#Form members)]) - ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") + (#Meta [_ (#Form members)]) + ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") - (#Meta [_ (#Record slots)]) - ($ text:++ "{" (|> slots - (map (:' (-> (, Syntax Syntax) Text) - (lambda [slot] - (let [[k v] slot] - ($ text:++ (syntax:show k) " " (syntax:show v)))))) - (interpose " ") (fold text:++ "")) "}") - )) + (#Meta [_ (#Record slots)]) + ($ text:++ "{" + (|> slots + (map (_lux_: (-> (, Syntax Syntax) Text) + (lambda [slot] + (let [[k v] slot] + ($ text:++ (syntax:show k) " " (syntax:show v)))))) + (interpose " ") + (fold text:++ "")) + "}") + )) (def__ #export (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) - (case' syntax - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))]) - (do Lux:Monad - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (case' ?macro - (#Some macro) - (do Lux:Monad - [expansion (macro args) - expansion' (map% Lux:Monad macro-expand expansion)] - (;return (list:join expansion'))) - - #None - (do Lux:Monad - [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] - (;return (list ($form (list:join parts'))))))) - - (#Meta [_ (#Form (#Cons [harg targs]))]) - (do Lux:Monad - [harg+ (macro-expand harg) - targs+ (map% Lux:Monad macro-expand targs)] - (;return (list ($form (list:++ harg+ (list:join targs+)))))) - - (#Meta [_ (#Tuple members)]) - (do Lux:Monad - [members' (map% Lux:Monad macro-expand members)] - (;return (list ($tuple (list:join members'))))) - - _ - (return (list syntax)))) + (_lux_case syntax + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))]) + (do Lux:Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Lux:Monad + [expansion (macro args) + expansion' (map% Lux:Monad macro-expand expansion)] + (;return (list:join expansion'))) + + #None + (do Lux:Monad + [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] + (;return (list ($form (list:join parts'))))))) + + (#Meta [_ (#Form (#Cons [harg targs]))]) + (do Lux:Monad + [harg+ (macro-expand harg) + targs+ (map% Lux:Monad macro-expand targs)] + (;return (list ($form (list:++ harg+ (list:join targs+)))))) + + (#Meta [_ (#Tuple members)]) + (do Lux:Monad + [members' (map% Lux:Monad macro-expand members)] + (;return (list ($tuple (list:join members'))))) + + _ + (return (list syntax)))) (def__ (walk-type type) (-> Syntax Syntax) - (case' type - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) parts]))]) - ($form (#Cons [($tag tag) (map walk-type parts)])) + (_lux_case type + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) parts]))]) + ($form (#Cons [($tag tag) (map walk-type parts)])) - (#Meta [_ (#Tuple members)]) - ($tuple (map walk-type members)) + (#Meta [_ (#Tuple members)]) + ($tuple (map walk-type members)) - (#Meta [_ (#Form (#Cons [type-fn args]))]) - (fold (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) - (walk-type type-fn) - (map walk-type args)) - - _ - type)) + (#Meta [_ (#Form (#Cons [type-fn args]))]) + (fold (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) + (walk-type type-fn) + (map walk-type args)) + + _ + type)) (defmacro #export (type` tokens) - (case' tokens - (#Cons [type #Nil]) - (do Lux:Monad - [type+ (macro-expand type)] - (case' type+ - (#Cons [type' #Nil]) - (;return (list (walk-type type'))) - - _ - (fail "type`: The expansion of the type-syntax had to yield a single element."))) - - _ - (fail "Wrong syntax for type`"))) + (_lux_case tokens + (#Cons [type #Nil]) + (do Lux:Monad + [type+ (macro-expand type)] + (_lux_case type+ + (#Cons [type' #Nil]) + (;return (list (walk-type type'))) + + _ + (fail "type`: The expansion of the type-syntax had to yield a single element."))) + + _ + (fail "Wrong syntax for type`"))) (defmacro #export (: tokens) - (case' tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (:' (;type` (~ type)) (~ value))))) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (list (`' (_lux_: (;type` (~ type)) (~ value))))) - _ - (fail "Wrong syntax for :"))) + _ + (fail "Wrong syntax for :"))) (defmacro #export (:! tokens) - (case' tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (:!' (;type` (~ type)) (~ value))))) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (list (`' (_lux_:! (;type` (~ type)) (~ value))))) - _ - (fail "Wrong syntax for :!"))) + _ + (fail "Wrong syntax for :!"))) (defmacro #export (deftype tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) - [true tokens'] + (_lux_case tokens + (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) + [true tokens'] - _ - [false tokens])) + _ + [false tokens])) parts (: (Maybe (, Syntax (List Syntax) Syntax)) - (case' tokens' - (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])]) - (#Some [($symbol name) #Nil type]) - - (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])]) - (#Some [($symbol name) args type]) - - _ - #None))] - (case' parts - (#Some [name args type]) - (let [with-export (: (List Syntax) - (if export? - (list (`' (export' (~ name)))) - #Nil)) - type' (: Syntax - (case' args - #Nil - type - - _ - (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (list& (`' (def' (~ name) (;type` (~ type')))) - with-export))) - - #None - (fail "Wrong syntax for deftype")) + (_lux_case tokens' + (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])]) + (#Some [($symbol name) #Nil type]) + + (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])]) + (#Some [($symbol name) args type]) + + _ + #None))] + (_lux_case parts + (#Some [name args type]) + (let [with-export (: (List Syntax) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)) + type' (: Syntax + (_lux_case args + #Nil + type + + _ + (`' (;All (~ name) [(~@ args)] (~ type)))))] + (return (list& (`' (_lux_def (~ name) (;type` (~ type')))) + with-export))) + + #None + (fail "Wrong syntax for deftype")) )) (deftype #export (IO a) (-> (,) a)) (defmacro #export (io tokens) - (case' tokens - (#Cons [value #Nil]) - (let [blank ($symbol ["" ""])] - (return (list (`' (lambda' (~ blank) (~ blank) (~ value)))))) + (_lux_case tokens + (#Cons [value #Nil]) + (let [blank ($symbol ["" ""])] + (return (list (`' (_lux_lambda (~ blank) (~ blank) (~ value)))))) - _ - (fail "Wrong syntax for io"))) + _ + (fail "Wrong syntax for io"))) (defmacro #export (exec tokens) - (case' (reverse tokens) - (#Cons [value actions]) - (let [dummy ($symbol ["" ""])] - (return (list (fold (lambda [post pre] (`' (case' (~ pre) (~ dummy) (~ post)))) - value - actions)))) + (_lux_case (reverse tokens) + (#Cons [value actions]) + (let [dummy ($symbol ["" ""])] + (return (list (fold (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) + value + actions)))) - _ - (fail "Wrong syntax for exec"))) + _ + (fail "Wrong syntax for exec"))) (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) - (case' tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) - [true tokens'] + (_lux_case tokens + (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) + [true tokens'] - _ - [false tokens])) + _ + [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) - (case' tokens' - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (#Some [name args (#Some type) body]) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (#Some [name #Nil (#Some type) body]) - - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) - - (#Cons [name (#Cons [body #Nil])]) - (#Some [name #Nil #None body]) - - _ - #None))] - (case' parts - (#Some [name args ?type body]) - (let [body' (: Syntax - (case' args - #Nil - body - - _ - (`' (;lambda (~ name) [(~@ args)] (~ body))))) - body'' (: Syntax - (case' ?type - (#Some type) - (`' (: (~ type) (~ body'))) - - #None - body'))] - (return (list& (`' (def' (~ name) (~ body''))) - (if export? - (list (`' (export' (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for def")))) + (_lux_case tokens' + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) + (#Some [name args (#Some type) body]) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (#Some [name #Nil (#Some type) body]) + + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Some [name args #None body]) + + (#Cons [name (#Cons [body #Nil])]) + (#Some [name #Nil #None body]) + + _ + #None))] + (_lux_case parts + (#Some [name args ?type body]) + (let [body' (: Syntax + (_lux_case args + #Nil + body + + _ + (`' (;lambda (~ name) [(~@ args)] (~ body))))) + body'' (: Syntax + (_lux_case ?type + (#Some type) + (`' (: (~ type) (~ body'))) + + #None + body'))] + (return (list& (`' (_lux_def (~ name) (~ body''))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) + + #None + (fail "Wrong syntax for def")))) (def (rejoin-pair pair) (-> (, Syntax Syntax) (List Syntax)) @@ -1588,28 +1597,28 @@ (list left right))) (defmacro #export (case tokens) - (case' tokens - (#Cons [value branches]) - (do Lux:Monad - [expansions (map% Lux:Monad - (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) - (lambda expander [branch] - (let [[pattern body] branch] - (case' pattern - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) macro-args]))]) - (do Lux:Monad - [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args))) - expansions (map% Lux:Monad expander (as-pairs expansion))] - (;return (list:join expansions))) - - _ - (;return (list branch)))))) - (as-pairs branches))] - (;return (list (`' (case' (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) - - _ - (fail "Wrong syntax for case"))) + (_lux_case tokens + (#Cons [value branches]) + (do Lux:Monad + [expansions (map% Lux:Monad + (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) + (lambda expander [branch] + (let [[pattern body] branch] + (_lux_case pattern + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) macro-args]))]) + (do Lux:Monad + [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args))) + expansions (map% Lux:Monad expander (as-pairs expansion))] + (;return (list:join expansions))) + + _ + (;return (list branch)))))) + (as-pairs branches))] + (;return (list (`' (_lux_case (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) + + _ + (fail "Wrong syntax for case"))) (defmacro #export (\ tokens) (case tokens @@ -1650,8 +1659,8 @@ (def (int:show int) (-> Int Text) - (jvm-invokevirtual java.lang.Object toString [] - int [])) + (_jvm_invokevirtual java.lang.Object toString [] + int [])) (defmacro #export (` tokens) (do Lux:Monad @@ -1692,7 +1701,7 @@ (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" ":'"])]) type (#Meta [_ (#Symbol name)])))])) + (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" "_lux_:"])]) type (#Meta [_ (#Symbol name)])))])) (do Lux:Monad [name' (normalize name)] (;return (: (, Ident Syntax) [name' type]))) @@ -1734,9 +1743,9 @@ _ (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (list& (`' (def' (~ name) (~ sigs'))) + (return (list& (`' (_lux_def (~ name) (~ sigs'))) (if export? - (list (`' (export' (~ name)))) + (list (`' (_lux_export (~ name)))) #Nil)))) #None @@ -1749,7 +1758,7 @@ (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" "def'"])]) (#Meta [_ (#Symbol name)]) value))])) + (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" "_lux_def"])]) (#Meta [_ (#Symbol name)]) value))])) (do Lux:Monad [name' (normalize name)] (;return (: (, Syntax Syntax) [($tag name') value]))) @@ -1788,7 +1797,7 @@ (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] (return (list& (`' (def (~ name) (~ type) (~ defs'))) (if export? - (list (`' (export' (~ name)))) + (list (`' (_lux_export (~ name)))) #Nil)))) #None @@ -1803,8 +1812,8 @@ (def (= x y) ( x y)))] - [Int:Eq Int jvm-leq] - [Real:Eq Real jvm-deq]) + [Int:Eq Int _jvm_leq] + [Real:Eq Real _jvm_deq]) (def #export (id x) (All [a] (-> a a)) @@ -1852,17 +1861,20 @@ [(defstruct #export (Ord ) (def (< x y) ( x y)) + (def (<= x y) (or ( x y) ( x y))) + (def (> x y) ( x y)) + (def (>= x y) (or ( x y) ( x y))))] - [Int:Ord Int jvm-llt jvm-lgt jvm-leq] - [Real:Ord Real jvm-dlt jvm-dgt jvm-deq]) + [Int:Ord Int _jvm_llt _jvm_lgt _jvm_leq] + [Real:Ord Real _jvm_dlt _jvm_dgt _jvm_deq]) (defmacro #export (alias-lux tokens state) (case state @@ -1880,8 +1892,7 @@ (list))))) lux)] (#Right [state (map (lambda [name] - (` ((~ ($symbol ["" "def'"])) (~ ($symbol ["" name])) - (~ ($symbol ["lux" name]))))) + (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name]))))) (list:join to-alias))])) #None @@ -1890,8 +1901,8 @@ (def #export (print x) (-> Text (,)) - (jvm-invokevirtual java.io.PrintStream print [java.lang.Object] - (jvm-getstatic java.lang.System out) [x])) + (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [x])) (def #export (println x) (-> Text (,)) @@ -1915,18 +1926,18 @@ (def (index-of part text) (-> Text Text Int) - (jvm-i2l (jvm-invokevirtual java.lang.String indexOf [java.lang.String] - text [part]))) + (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String] + text [part]))) (def (substring1 idx text) (-> Int Text Text) - (jvm-invokevirtual java.lang.String substring [int] - text [(jvm-l2i idx)])) + (_jvm_invokevirtual java.lang.String substring [int] + text [(_jvm_l2i idx)])) (def (substring2 idx1 idx2 text) (-> Int Int Text Text) - (jvm-invokevirtual java.lang.String substring [int int] - text [(jvm-l2i idx1) (jvm-l2i idx2)])) + (_jvm_invokevirtual java.lang.String substring [int int] + text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) (def (split-slot slot) (-> Text (, Text Text)) @@ -1986,22 +1997,22 @@ [($tag [module name]) ($symbol ["" name])]))) slots)) _ (println (text:++ "Using pattern: " (syntax:show pattern)))] - (#Right [state (list (` (case' (~ struct) (~ pattern) (~ body))))])) + (#Right [state (list (` (_lux_case (~ struct) (~ pattern) (~ body))))])) _ (#Left "Can only \"use\" records.")))))) _ (let [dummy ($symbol ["" ""])] - (#Right [state (list (` (case' (~ struct) - (~ dummy) - (using (~ dummy) (~ body)))))]))) + (#Right [state (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) (~ body)))))]))) _ (#Left "Wrong syntax for defsig"))) ## (defmacro (loop tokens) -## (case' tokens +## (_lux_case tokens ## (#Cons [bindings (#Cons [body #Nil])]) ## (let [pairs (as-pairs bindings)] ## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["" "recur"])) (~ (#Tuple (map first pairs))) @@ -2009,7 +2020,7 @@ ## (map second pairs)]))))))) ## (defmacro (get@ tokens) -## (let [output (case' tokens +## (let [output (_lux_case tokens ## (#Cons [tag (#Cons [record #Nil])]) ## (` (get@' (~ tag) (~ record))) @@ -2018,7 +2029,7 @@ ## (return (list output)))) ## (defmacro (set@ tokens) -## (let [output (case' tokens +## (let [output (_lux_case tokens ## (#Cons [tag (#Cons [value (#Cons [record #Nil])])]) ## (` (set@' (~ tag) (~ value) (~ record))) @@ -2030,7 +2041,7 @@ ## (return (list output)))) ## (defmacro (update@ tokens) -## (let [output (case' tokens +## (let [output (_lux_case tokens ## (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) ## (` (let [_record_ (~ record)] ## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_))) diff --git a/source/program.lux b/source/program.lux index 2bbf3fd4f..20f7863ab 100644 --- a/source/program.lux +++ b/source/program.lux @@ -11,8 +11,8 @@ (list& x (filter p xs')) (filter p xs')))) -(jvm-program _ - (exec (println "Hello, world!") - (|> (int:+ 2 2) ->text ($ text:++ "2 + 2 = ") println) - (println (->text (using Int:Ord - (< 5 10)))))) +(_jvm_program _ + (exec (println "Hello, world!") + (|> (int:+ 2 2) ->text ($ text:++ "2 + 2 = ") println) + (println (->text (using Int:Ord + (< 5 10)))))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 939a3ea0a..a47360ffb 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -14,14 +14,14 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-catch"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_catch"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?ex-class]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?ex-arg]]]] ["lux;Cons" [?catch-body ["lux;Nil" _]]]]]]]]]]]]] (&/T (&/|++ catch+ (|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-finally"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_finally"]]]] ["lux;Cons" [?finally-body ["lux;Nil" _]]]]]]]]] (&/T catch+ ?finally-body))) @@ -59,7 +59,7 @@ [["lux;Meta" [meta ["lux;Tag" ?ident]]]] (&&lux/analyse-variant analyse exo-type ?ident unit) - [["lux;Meta" [meta ["lux;Symbol" [_ "jvm-null"]]]]] + [["lux;Meta" [meta ["lux;Symbol" [_ "_jvm_null"]]]]] (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) [_] @@ -71,46 +71,46 @@ [["lux;Meta" [meta ["lux;Symbol" ?ident]]]] (&&lux/analyse-symbol analyse exo-type ?ident) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "case'"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_case"]]]] ["lux;Cons" [?value ?branches]]]]]]]] (&&lux/analyse-case analyse exo-type ?value ?branches) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "lambda'"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_lambda"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?self]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?arg]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]]]]]] (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "def'"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_def"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]] (&&lux/analyse-def analyse ?name ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "declare-macro'"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_declare-macro"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]] ["lux;Nil" _]]]]]]]]] (&&lux/analyse-declare-macro analyse ?name) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "import'"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_import"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Text" ?path]]] ["lux;Nil" _]]]]]]]]] (&&lux/analyse-import analyse ?path) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ":'"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_:"]]]] ["lux;Cons" [?type ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]] (&&lux/analyse-check analyse eval! exo-type ?type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ":!'"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_:!"]]]] ["lux;Cons" [?type ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]] (&&lux/analyse-coerce analyse eval! ?type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "export'"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_export"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?ident]]]] ["lux;Nil" _]]]]]]]]] (&&lux/analyse-export analyse ?ident) @@ -122,53 +122,53 @@ (matchv ::M/objects [token] ;; Host special forms ;; Integer arithmetic - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-iadd analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-isub analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-imul analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-idiv analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-irem analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-ieq analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-ilt analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-igt analyse ?x ?y) ;; Long arithmetic - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-ladd analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lsub analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lmul analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-ldiv analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lrem analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-leq analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-llt analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lgt analyse ?x ?y) [_] @@ -177,53 +177,53 @@ (defn ^:private aba4 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Float arithmetic - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-fadd analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-fsub analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-fmul analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-fdiv analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-frem analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-feq analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-flt analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-fgt analyse ?x ?y) ;; Double arithmetic - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-dadd analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-dsub analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-dmul analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-ddiv analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-drem analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-deq analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-dlt analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-dgt analyse ?x ?y) [_] @@ -232,39 +232,39 @@ (defn ^:private aba5 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Objects - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-null?"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_null?"]]]] ["lux;Cons" [?object ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-null? analyse ?object) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-new"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_new"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?class]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]] ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-new analyse ?class ?classes ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-getstatic"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_getstatic"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]] ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-getstatic analyse ?class ?field) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-getfield"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_getfield"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]] ["lux;Cons" [?object ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-getfield analyse ?class ?field ?object) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-putstatic"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_putstatic"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-putstatic analyse ?class ?field ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-putfield"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_putfield"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]] ["lux;Cons" [?object @@ -272,7 +272,7 @@ ["lux;Nil" _]]]]]]]]]]]]]]] (&&host/analyse-jvm-putfield analyse ?class ?field ?object ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-invokestatic"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_invokestatic"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] @@ -280,7 +280,7 @@ ["lux;Nil" _]]]]]]]]]]]]]]] (&&host/analyse-jvm-invokestatic analyse ?class ?method ?classes ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-invokevirtual"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_invokevirtual"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] @@ -289,7 +289,7 @@ ["lux;Nil" _]]]]]]]]]]]]]]]]] (&&host/analyse-jvm-invokevirtual analyse ?class ?method ?classes ?object ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-invokeinterface"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_invokeinterface"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] @@ -298,7 +298,7 @@ ["lux;Nil" _]]]]]]]]]]]]]]]]] (&&host/analyse-jvm-invokeinterface analyse ?class ?method ?classes ?object ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-invokespecial"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_invokespecial"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] @@ -308,23 +308,23 @@ (&&host/analyse-jvm-invokespecial analyse ?class ?method ?classes ?object ?args) ;; Exceptions - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-try"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_try"]]]] ["lux;Cons" [?body ?handlers]]]]]]]] (&&host/analyse-jvm-try analyse ?body (&/fold parse-handler [(list) nil] ?handlers)) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-throw"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_throw"]]]] ["lux;Cons" [?ex ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-throw analyse ?ex) ;; Syncronization/monitos - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-monitorenter"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_monitorenter"]]]] ["lux;Cons" [?monitor ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-monitorenter analyse ?monitor) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-monitorexit"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_monitorexit"]]]] ["lux;Cons" [?monitor ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-monitorexit analyse ?monitor) @@ -335,74 +335,74 @@ (defn ^:private aba6 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Primitive conversions - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-d2f analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-d2i analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-d2l analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-f2d analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-f2i analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-f2l analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-i2b analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-i2c analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-i2d analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-i2f analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-i2l analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-i2s analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-l2d analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-l2f analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-l2i analyse ?value) ;; Bitwise operators - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-iand analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-ior analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-land analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lor analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lxor analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lshl analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lshr analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lushr analyse ?x ?y) [_] @@ -411,40 +411,40 @@ (defn ^:private aba7 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Arrays - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-new-array"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_new-array"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?class]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Int" ?length]]] ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-new-array analyse ?class ?length) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-aastore"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_aastore"]]]] ["lux;Cons" [?array ["lux;Cons" [["lux;Meta" [_ ["lux;Int" ?idx]]] ["lux;Cons" [?elem ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-aaload"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_aaload"]]]] ["lux;Cons" [?array ["lux;Cons" [["lux;Meta" [_ ["lux;Int" ?idx]]] ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-class"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_class"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?super-class]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?fields]]] ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-class analyse ?name ?super-class ?fields) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-interface"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_interface"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]] ?members]]]]]]]] (&&host/analyse-jvm-interface analyse ?name ?members) ;; Programs - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-program"]]]] + [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_program"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?args]]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]]]] @@ -459,7 +459,7 @@ [["lux;Right" [state* output]]] (return* state* output) - [_] + [["lux;Left" ""]] (matchv ::M/objects [((aba2 analyse eval! exo-type token) state)] [["lux;Right" [state* output]]] (return* state* output) @@ -489,26 +489,26 @@ [["lux;Right" [state* output]]] (return* state* output) - [_] - (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))) + [["lux;Left" msg]] + (fail* msg)) - [_] - (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))) + [["lux;Left" msg]] + (fail* msg)) - [_] - (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))) + [["lux;Left" msg]] + (fail* msg)) - [_] - (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))) + [["lux;Left" msg]] + (fail* msg)) - [_] - (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))) + [["lux;Left" msg]] + (fail* msg)) - [_] - (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))) + [["lux;Left" msg]] + (fail* msg)) - [_] - (fail* (str "[Analyser Error] Unmatched token: " (&/show-ast token)))))) + [["lux;Left" msg]] + (fail* msg)))) (defn ^:private analyse-ast [eval! exo-type token] (matchv ::M/objects [token] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 3631bddb2..527c69dc7 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -159,7 +159,7 @@ (defn analyse-jvm-interface [analyse ?name ?members] (|do [=members (&/map% (fn [member] (matchv ::M/objects [member] - [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ":'"]]]] + [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ":"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "->"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?inputs]]] ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?output]]]] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index e4237d8dd..b65963e4a 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -110,44 +110,44 @@ [inner outer] (&/|split-with no-binding? stack)] (matchv ::M/objects [outer] [["lux;Nil" _]] - (&/run-state (|do [[[r-module r-name] $def] (&&module/find-def (if (= "" ?module) module-name ?module) - ?name) - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) + ((|do [[[r-module r-name] $def] (&&module/find-def (if (= "" ?module) module-name ?module) + ?name) + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" ?type]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state) [["lux;Cons" [?genv ["lux;Nil" _]]]] (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] (matchv ::M/objects [global] [[["lux;Global" [?module* ?name*]] _]] - (&/run-state (|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) + ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" ?type]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state) [_] (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")) @@ -165,10 +165,10 @@ (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) (&/|list)) (&/|reverse inner) scopes)] - (&/run-state (|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] - (return (&/|list =local))) - (&/set$ &/$ENVS (&/|++ inner* outer) state))) + ((|do [btype (&&/expr-type =local) + _ (&type/check exo-type btype)] + (return (&/|list =local))) + (&/set$ &/$ENVS (&/|++ inner* outer) state))) ))) )) @@ -263,12 +263,7 @@ (|do [? (&type/bound? ?id)] (if ? (|do [dtype (&type/deref ?id)] - (matchv ::M/objects [dtype] - [["lux;ExT" _]] - (return (&/T _expr exo-type)) - - [_] - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) + (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)))))))) [_] diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 5960d3080..f36dc044a 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -71,8 +71,8 @@ (if (or exported? (= current-module module)) (matchv ::M/objects [$$def] [["lux;AliasD" [?r-module ?r-name]]] - (&/run-state (find-def ?r-module ?r-name) - state) + ((find-def ?r-module ?r-name) + state) [_] (return* state (&/T (&/T module name) $$def))) @@ -94,19 +94,19 @@ (if-let [$def (&/|get name $module)] (matchv ::M/objects [$def] [[exported? ["lux;ValueD" ?type]]] - (&/run-state (|do [_ (&type/check &type/Macro ?type) - ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (&host/location (&/|list module name))) - (.getField "_datum") - (.get nil))]] - (fn [state*] - (return* (&/update$ &/$MODULES - (fn [$modules] - (&/|put module (&/|put name (&/T exported? (&/V "lux;MacroD" macro)) $module) - $modules)) - state*) - nil))) - state) + ((|do [_ (&type/check &type/Macro ?type) + ^ClassLoader loader &/loader + :let [macro (-> (.loadClass loader (&host/location (&/|list module name))) + (.getField "_datum") + (.get nil))]] + (fn [state*] + (return* (&/update$ &/$MODULES + (fn [$modules] + (&/|put module (&/|put name (&/T exported? (&/V "lux;MacroD" macro)) $module) + $modules)) + state*) + nil))) + state) [[_ ["lux;MacroD" _]]] (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 9ea255132..3ac994043 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -32,12 +32,18 @@ (defn T [& elems] (to-array elems)) +;; (definline T [& elems] +;; `(to-array (list ~@elems))) (defn V [tag value] (to-array [tag value])) +;; (definline V [tag value] +;; `(to-array [~tag ~value])) (defn R [& kvs] (to-array kvs)) +;; (definline R [& kvs] +;; `(to-array (list ~@kvs))) (defn get$ [slot ^objects record] (aget record slot)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 6739c5529..26b75bec3 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -352,14 +352,15 @@ (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (&host/->class name) nil "java/lang/Object" nil))] - (matchv ::M/objects [(&/run-state (&/exhaust% compiler-step) (->> state - (&/set$ &/$SOURCE (&reader/from (str "source/" name ".lux"))) - (&/set$ &/$ENVS (&/|list (&/env name))) - (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %)) - (&/update$ &/$MODULES #(&/|put name &a-module/init-module %))))] + (matchv ::M/objects [((&/exhaust% compiler-step) + (->> state + (&/set$ &/$SOURCE (&reader/from (str "source/" name ".lux"))) + (&/set$ &/$ENVS (&/|list (&/env name))) + (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %)) + (&/update$ &/$MODULES #(&/|put name &a-module/init-module %))))] [["lux;Right" [?state _]]] (do (.visitEnd =class) - (&/run-state (&&/save-class! name (.toByteArray =class)) ?state)) + ((&&/save-class! name (.toByteArray =class)) ?state)) [["lux;Left" ?message]] (fail* ?message))))))) @@ -367,7 +368,7 @@ ;; [Resources] (defn compile-all [modules] (.mkdir (java.io.File. "output")) - (matchv ::M/objects [(&/run-state (&/map% compile-module (&/|cons "lux" modules)) (&/init-state nil))] + (matchv ::M/objects [((&/map% compile-module (&/|cons "lux" modules)) (&/init-state nil))] [["lux;Right" [?state _]]] (println (str "Compilation complete! " (str "[" (->> modules (&/|interpose " ") diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 6a954d5ff..69c95ea6a 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -27,12 +27,12 @@ ))) ;; [Exports] -(defn ^:private re-find! [regex line] +(defn ^:private re-find! [^java.util.regex.Pattern regex line] (let [matcher (.matcher regex line)] (when (.find matcher) (.group matcher 0)))) -(defn ^:private re-find3! [regex line] +(defn ^:private re-find3! [^java.util.regex.Pattern regex line] (let [matcher (.matcher regex line)] (when (.find matcher) (list (.group matcher 0) diff --git a/src/lux/type.clj b/src/lux/type.clj index b2ea0ff0d..494d8ebbc 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -226,33 +226,33 @@ (|do [ex existential] (set-var id ex)))] (fn [state] - (&/run-state (|do [mappings* (&/map% (fn [binding] - (|let [[?id ?type] binding] - (if (= id ?id) - (return binding) - (matchv ::M/objects [?type] - [["lux;None" _]] - (return binding) - - [["lux;Some" ?type*]] - (matchv ::M/objects [?type*] - [["lux;VarT" ?id*]] - (if (= id ?id*) - (return (&/T ?id (&/V "lux;None" nil))) - (return binding)) - - [_] - (|do [?type** (clean* id ?type*)] - (return (&/T ?id (&/V "lux;Some" ?type**))))) - )))) - (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))] - (fn [state] - (return* (&/update$ &/$TYPES #(->> % - (&/update$ &/$COUNTER dec) - (&/set$ &/$MAPPINGS (&/|remove id mappings*))) - state) - nil))) - state)))) + ((|do [mappings* (&/map% (fn [binding] + (|let [[?id ?type] binding] + (if (= id ?id) + (return binding) + (matchv ::M/objects [?type] + [["lux;None" _]] + (return binding) + + [["lux;Some" ?type*]] + (matchv ::M/objects [?type*] + [["lux;VarT" ?id*]] + (if (= id ?id*) + (return (&/T ?id (&/V "lux;None" nil))) + (return binding)) + + [_] + (|do [?type** (clean* id ?type*)] + (return (&/T ?id (&/V "lux;Some" ?type**))))) + )))) + (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))] + (fn [state] + (return* (&/update$ &/$TYPES #(->> % + (&/update$ &/$COUNTER dec) + (&/set$ &/$MAPPINGS (&/|remove id mappings*))) + state) + nil))) + state)))) (defn with-var [k] (|do [id create-var @@ -585,24 +585,49 @@ (check* fixpoints expected bound)))) [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] - (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - _ (check* fixpoints A1 A2)] - (return (&/T fixpoints nil))) + (&/try-all% (&/|list (|do [F1 (deref ?eid)] + (&/try-all% (&/|list (|do [F2 (deref ?aid)] + (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)))) + (|do [F2 (deref ?aid)] + (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + [fixpoints** _] (check* fixpoints* A1 A2)] + (return (&/T fixpoints** nil))))) + ;; (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + ;; _ (check* fixpoints A1 A2)] + ;; (return (&/T fixpoints nil))) [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) - e* (apply-type F2 A1) - a* (apply-type F2 A2) - [fixpoints** _] (check* fixpoints* e* a*)] - (return (&/T fixpoints** nil))) - - [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) - e* (apply-type F1 A1) - a* (apply-type F1 A2) - [fixpoints** _] (check* fixpoints* e* a*)] - (return (&/T fixpoints** nil))) + (&/try-all% (&/|list (|do [F1 (deref ?id)] + (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + e* (apply-type F2 A1) + a* (apply-type F2 A2) + [fixpoints** _] (check* fixpoints* e* a*)] + (return (&/T fixpoints** nil))))) + ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + ;; e* (apply-type F2 A1) + ;; a* (apply-type F2 A2) + ;; [fixpoints** _] (check* fixpoints* e* a*)] + ;; (return (&/T fixpoints** nil))) + [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + (&/try-all% (&/|list (|do [F2 (deref ?id)] + (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + e* (apply-type F1 A1) + a* (apply-type F1 A2) + [fixpoints** _] (check* fixpoints* e* a*)] + (return (&/T fixpoints** nil))))) + ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + ;; e* (apply-type F1 A1) + ;; a* (apply-type F1 A2) + ;; [fixpoints** _] (check* fixpoints* e* a*)] + ;; (return (&/T fixpoints** nil))) + [["lux;AppT" [F A]] _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) -- cgit v1.2.3 From 5a13be9d9646819a00c281cea759f5b1c2eb883b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 10 May 2015 21:12:56 -0400 Subject: - Changed the names of the tags of the Syntax type to differentiate them better from the tags of the Type type. --- source/lux.lux | 452 +++++++++++++++++++++++----------------------- src/lux/analyser.clj | 284 ++++++++++++++--------------- src/lux/analyser/case.clj | 28 +-- src/lux/analyser/host.clj | 22 +-- src/lux/analyser/lux.clj | 2 +- src/lux/host.clj | 2 +- src/lux/parser.clj | 20 +- src/lux/type.clj | 20 +- 8 files changed, 415 insertions(+), 415 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index f2a6f70da..3b7bb9702 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -131,16 +131,16 @@ (_lux_export Meta) ## (deftype (Syntax' w) -## (| (#Bool Bool) -## (#Int Int) -## (#Real Real) -## (#Char Char) -## (#Text Text) -## (#Symbol (, Text Text)) -## (#Tag (, Text Text)) -## (#Form (List (w (Syntax' w)))) -## (#Tuple (List (w (Syntax' w)))) -## (#Record (List (, (w (Syntax' w)) (w (Syntax' w))))))) +## (| (#BoolS Bool) +## (#IntS Int) +## (#RealS Real) +## (#CharS Char) +## (#TextS Text) +## (#SymbolS (, Text Text)) +## (#TagS (, Text Text)) +## (#FormS (List (w (Syntax' w)))) +## (#TupleS (List (w (Syntax' w)))) +## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) (_lux_def Syntax' (_lux_case (#AppT [(#BoundT "w") (#AppT [(#BoundT "Syntax'") @@ -149,16 +149,16 @@ (_lux_case (#AppT [List Syntax]) SyntaxList (#AllT [#None "Syntax'" "w" - (#VariantT (#Cons [["lux;Bool" Bool] - (#Cons [["lux;Int" Int] - (#Cons [["lux;Real" Real] - (#Cons [["lux;Char" Char] - (#Cons [["lux;Text" Text] - (#Cons [["lux;Symbol" Ident] - (#Cons [["lux;Tag" Ident] - (#Cons [["lux;Form" SyntaxList] - (#Cons [["lux;Tuple" SyntaxList] - (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] + (#VariantT (#Cons [["lux;BoolS" Bool] + (#Cons [["lux;IntS" Int] + (#Cons [["lux;RealS" Real] + (#Cons [["lux;CharS" Char] + (#Cons [["lux;TextS" Text] + (#Cons [["lux;SymbolS" Ident] + (#Cons [["lux;TagS" Ident] + (#Cons [["lux;FormS" SyntaxList] + (#Cons [["lux;TupleS" SyntaxList] + (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] #Nil]) ])])])])])])])])]) )])))) @@ -319,32 +319,32 @@ (_lux_def $text (_lux_: (#LambdaT [Text Syntax]) (_lux_lambda _ text - (_meta (#Text text))))) + (_meta (#TextS text))))) (_lux_def $symbol (_lux_: (#LambdaT [Ident Syntax]) (_lux_lambda _ ident - (_meta (#Symbol ident))))) + (_meta (#SymbolS ident))))) (_lux_def $tag (_lux_: (#LambdaT [Ident Syntax]) (_lux_lambda _ ident - (_meta (#Tag ident))))) + (_meta (#TagS ident))))) (_lux_def $form (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) (_lux_lambda _ tokens - (_meta (#Form tokens))))) + (_meta (#FormS tokens))))) (_lux_def $tuple (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) (_lux_lambda _ tokens - (_meta (#Tuple tokens))))) + (_meta (#TupleS tokens))))) (_lux_def $record (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) (_lux_lambda _ tokens - (_meta (#Record tokens))))) + (_meta (#RecordS tokens))))) (_lux_def let' (_lux_: Macro @@ -363,34 +363,34 @@ (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens - (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_lambda"])) - (#Cons [(_meta (#Symbol ["" ""])) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) + (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS ["" ""])) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) #Nil])) - (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_lambda"])) - (#Cons [(_meta (#Symbol self)) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [(_meta (#Tuple args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) + (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS self)) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) #Nil])) _ @@ -401,55 +401,55 @@ (_lux_: Macro (lambda_ [tokens] (_lux_case tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#Form (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#Tuple args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) #Nil])) (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) #Nil])) _ @@ -460,7 +460,7 @@ (def_ #export (defmacro tokens) Macro (_lux_case tokens - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) (return (#Cons [($form (#Cons [($symbol ["lux" "def_"]) (#Cons [($form (#Cons [name args])) (#Cons [($symbol ["lux" "Macro"]) @@ -470,7 +470,7 @@ (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #Nil])])) - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])])]) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) (return (#Cons [($form (#Cons [($symbol ["lux" "def_"]) (#Cons [($tag ["" "export"]) (#Cons [($form (#Cons [name args])) @@ -491,18 +491,18 @@ (defmacro (->' tokens) (_lux_case tokens (#Cons [input (#Cons [output #Nil])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) #Nil])) (#Cons [input (#Cons [output others])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) - (#Cons [(_meta (#Tuple (#Cons [input - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) #Nil])) _ @@ -510,23 +510,23 @@ (defmacro (All' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#Tuple #Nil)]) + (#Cons [(#Meta [_ (#TupleS #Nil)]) (#Cons [body #Nil])]) (return (#Cons [body #Nil])) - (#Cons [(#Meta [_ (#Tuple (#Cons [(#Meta [_ (#Symbol ["" arg-name])]) other-args]))]) + (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) (#Cons [body #Nil])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"])) - (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"])) - (#Cons [(_meta (#Text "")) - (#Cons [(_meta (#Text arg-name)) - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"])) - (#Cons [(_meta (#Tuple other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) + (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) + (#Cons [(_meta (#TextS "")) + (#Cons [(_meta (#TextS arg-name)) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) + (#Cons [(_meta (#TupleS other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) #Nil])) _ @@ -534,11 +534,11 @@ (defmacro (B' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#Symbol ["" bound-name])]) + (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) #Nil]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"])) - (#Cons [(_meta (#Text bound-name)) - #Nil])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) + (#Cons [(_meta (#TextS bound-name)) + #Nil])]))) #Nil])) _ @@ -550,11 +550,11 @@ (return tokens) (#Cons [x (#Cons [y xs])]) - (return (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"])) - (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"])) - (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) + (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) #Nil])) _ @@ -582,10 +582,10 @@ (defmacro #export (list xs) (return (#Cons [(fold (lambda_ [tail head] - (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"])) - (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) - (_meta (#Tag ["lux" "Nil"])) + (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) + (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) + (_meta (#TagS ["lux" "Nil"])) (reverse xs)) #Nil]))) @@ -593,8 +593,8 @@ (_lux_case (reverse xs) (#Cons [last init]) (return (list (fold (lambda_ [tail head] - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) - (_meta (#Tuple (list head tail))))))) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) last init))) @@ -604,13 +604,13 @@ (defmacro #export (lambda tokens) (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) (_lux_case tokens - (#Cons [(#Meta [_ (#Symbol name)]) tokens']) + (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) [name tokens'] _ [["" ""] tokens])) (_lux_case tokens' - (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) (_lux_case args #Nil (fail "lambda requires a non-empty arguments tuple.") @@ -632,8 +632,8 @@ (defmacro (def__ tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) (return (list ($form (list ($symbol ["" "_lux_def"]) name @@ -645,7 +645,7 @@ body)))))) ($form (list ($symbol ["" "_lux_export"]) name)))) - (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (list ($form (list ($symbol ["" "_lux_def"]) name ($form (list ($symbol ["" "_lux_:"]) @@ -653,7 +653,7 @@ body)))) ($form (list ($symbol ["" "_lux_export"]) name)))) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) (return (list ($form (list ($symbol ["" "_lux_def"]) name @@ -685,13 +685,13 @@ (defmacro #export (let tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) (return (list (fold (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) Syntax) (lambda [body binding] (_lux_case binding [label value] - (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))) + (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) body (fold (lambda [tail head] (#Cons [head tail])) #Nil @@ -725,7 +725,7 @@ (def__ (spliced? token) (->' Syntax Bool) (_lux_case token - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [_ #Nil])]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) true _ @@ -733,19 +733,19 @@ (def__ (wrap-meta content) (->' Syntax Syntax) - (_meta (#Form (list (_meta (#Tag ["lux" "Meta"])) - (_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Text "")) (_meta (#Int -1)) (_meta (#Int -1))))) - content))))))) + (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) + (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) + content))))))) (def__ (untemplate-list tokens) (->' ($' List Syntax) Syntax) (_lux_case tokens #Nil - (_meta (#Tag ["lux" "Nil"])) + (_meta (#TagS ["lux" "Nil"])) (#Cons [token tokens']) - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) - (_meta (#Tuple (list token (untemplate-list tokens'))))))))) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list token (untemplate-list tokens'))))))))) (def__ (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) @@ -772,7 +772,7 @@ true (let [elems' (map (lambda [elem] (_lux_case elem - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [spliced #Nil])]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) spliced _ @@ -791,50 +791,50 @@ (def__ (untemplate subst token) (->' Text Syntax Syntax) (_lux_case token - (#Meta [_ (#Bool value)]) - (wrap-meta ($form (list ($tag ["lux" "Bool"]) (_meta (#Bool value))))) + (#Meta [_ (#BoolS value)]) + (wrap-meta ($form (list ($tag ["lux" "BoolS"]) (_meta (#BoolS value))))) - (#Meta [_ (#Int value)]) - (wrap-meta ($form (list ($tag ["lux" "Int"]) (_meta (#Int value))))) + (#Meta [_ (#IntS value)]) + (wrap-meta ($form (list ($tag ["lux" "IntS"]) (_meta (#IntS value))))) - (#Meta [_ (#Real value)]) - (wrap-meta ($form (list ($tag ["lux" "Real"]) (_meta (#Real value))))) + (#Meta [_ (#RealS value)]) + (wrap-meta ($form (list ($tag ["lux" "RealS"]) (_meta (#RealS value))))) - (#Meta [_ (#Char value)]) - (wrap-meta ($form (list ($tag ["lux" "Char"]) (_meta (#Char value))))) + (#Meta [_ (#CharS value)]) + (wrap-meta ($form (list ($tag ["lux" "CharS"]) (_meta (#CharS value))))) - (#Meta [_ (#Text value)]) - (wrap-meta ($form (list ($tag ["lux" "Text"]) (_meta (#Text value))))) + (#Meta [_ (#TextS value)]) + (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value))))) - (#Meta [_ (#Tag [module name])]) + (#Meta [_ (#TagS [module name])]) (let [module' (_lux_case module "" subst _ module)] - (wrap-meta ($form (list ($tag ["lux" "Tag"]) ($tuple (list ($text module') ($text name))))))) + (wrap-meta ($form (list ($tag ["lux" "TagS"]) ($tuple (list ($text module') ($text name))))))) - (#Meta [_ (#Symbol [module name])]) + (#Meta [_ (#SymbolS [module name])]) (let [module' (_lux_case module "" subst _ module)] - (wrap-meta ($form (list ($tag ["lux" "Symbol"]) ($tuple (list ($text module') ($text name))))))) + (wrap-meta ($form (list ($tag ["lux" "SymbolS"]) ($tuple (list ($text module') ($text name))))))) - (#Meta [_ (#Tuple elems)]) - (splice (untemplate subst) ($tag ["lux" "Tuple"]) elems) + (#Meta [_ (#TupleS elems)]) + (splice (untemplate subst) ($tag ["lux" "TupleS"]) elems) - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))]) unquoted - (#Meta [_ (#Form elems)]) - (splice (untemplate subst) ($tag ["lux" "Form"]) elems) + (#Meta [_ (#FormS elems)]) + (splice (untemplate subst) ($tag ["lux" "FormS"]) elems) - (#Meta [_ (#Record fields)]) - (wrap-meta ($form (list ($tag ["lux" "Record"]) + (#Meta [_ (#RecordS fields)]) + (wrap-meta ($form (list ($tag ["lux" "RecordS"]) (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) (lambda [kv] (let [[k v] kv] @@ -855,7 +855,7 @@ (#Cons [init apps]) (return (list (fold (lambda [acc app] (_lux_case app - (#Meta [_ (#Form parts)]) + (#Meta [_ (#FormS parts)]) ($form (list:++ parts (list acc))) _ @@ -927,8 +927,8 @@ (defmacro #export (^ tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) - (return (list (`' (#;DataT (~ (_meta (#Text class-name))))))) + (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) + (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) _ (fail "Wrong syntax for ^"))) @@ -948,12 +948,12 @@ (defmacro (do tokens) (_lux_case tokens - (#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) + (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) (let [body' (fold (_lux_: (-> Syntax (, Syntax Syntax) Syntax) (lambda [body' binding] (let [[var value] binding] (_lux_case var - (#Meta [_ (#Tag ["" "let"])]) + (#Meta [_ (#TagS ["" "let"])]) (`' (;let (~ value) (~ body'))) _ @@ -999,7 +999,7 @@ (def__ (get-ident x) (-> Syntax ($' Maybe Text)) (_lux_case x - (#Meta [_ (#Symbol ["" sname])]) + (#Meta [_ (#SymbolS ["" sname])]) (#Some sname) _ @@ -1008,7 +1008,7 @@ (def__ (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) (_lux_case tuple - (#Meta [_ (#Tuple members)]) + (#Meta [_ (#TupleS members)]) (#Some members) _ @@ -1047,7 +1047,7 @@ (def__ (apply-template env template) (-> RepEnv Syntax Syntax) (_lux_case template - (#Meta [_ (#Symbol ["" sname])]) + (#Meta [_ (#SymbolS ["" sname])]) (_lux_case (get-rep sname env) (#Some subst) subst @@ -1055,13 +1055,13 @@ _ template) - (#Meta [_ (#Tuple elems)]) + (#Meta [_ (#TupleS elems)]) ($tuple (map (apply-template env) elems)) - (#Meta [_ (#Form elems)]) + (#Meta [_ (#FormS elems)]) ($form (map (apply-template env) elems)) - (#Meta [_ (#Record members)]) + (#Meta [_ (#RecordS members)]) ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) (lambda [kv] (let [[slot value] kv] @@ -1083,7 +1083,7 @@ (defmacro #export (do-template tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [(#Meta [_ (#Tuple templates)]) data])]) + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) [(map% Maybe:Monad get-ident bindings) (map% Maybe:Monad tuple->list data)]) @@ -1155,7 +1155,7 @@ (def__ (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) (_lux_case syntax - (#Meta [_ (#Symbol ["" name])]) + (#Meta [_ (#SymbolS ["" name])]) (_lux_case (get-rep name reps) (#Some replacement) replacement @@ -1163,18 +1163,18 @@ #None syntax) - (#Meta [_ (#Form parts)]) - (#Meta [_ (#Form (map (replace-syntax reps) parts))]) + (#Meta [_ (#FormS parts)]) + (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) - (#Meta [_ (#Tuple members)]) - (#Meta [_ (#Tuple (map (replace-syntax reps) members))]) + (#Meta [_ (#TupleS members)]) + (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - (#Meta [_ (#Record slots)]) - (#Meta [_ (#Record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))]) + (#Meta [_ (#RecordS slots)]) + (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[k v] slot] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))]) _ syntax) @@ -1183,13 +1183,13 @@ (defmacro #export (All tokens) (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) (_lux_case tokens - (#Cons [(#Meta [_ (#Symbol ["" self-ident])]) tokens']) + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) [self-ident tokens'] _ ["" tokens]))] (_lux_case tokens' - (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) (_lux_case (map% Maybe:Monad get-ident args) (#Some idents) (_lux_case idents @@ -1309,12 +1309,12 @@ (_lux_: (-> Syntax ($' Lux Syntax)) (lambda [token] (_lux_case token - (#Meta [_ (#Tag ident)]) + (#Meta [_ (#TagS ident)]) (do Lux:Monad [ident (normalize ident)] (;return (`' [(~ ($text (ident->text ident))) (;,)]))) - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) (do Lux:Monad [ident (normalize ident)] (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) @@ -1332,7 +1332,7 @@ (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) (lambda [pair] (_lux_case pair - [(#Meta [_ (#Tag ident)]) value] + [(#Meta [_ (#TagS ident)]) value] (do Lux:Monad [ident (normalize ident)] (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) @@ -1362,34 +1362,34 @@ (def__ #export (syntax:show syntax) (-> Syntax Text) (_lux_case syntax - (#Meta [_ (#Bool value)]) + (#Meta [_ (#BoolS value)]) (->text value) - (#Meta [_ (#Int value)]) + (#Meta [_ (#IntS value)]) (->text value) - (#Meta [_ (#Real value)]) + (#Meta [_ (#RealS value)]) (->text value) - (#Meta [_ (#Char value)]) + (#Meta [_ (#CharS value)]) ($ text:++ "#\"" (->text value) "\"") - (#Meta [_ (#Text value)]) + (#Meta [_ (#TextS value)]) value - (#Meta [_ (#Symbol ident)]) + (#Meta [_ (#SymbolS ident)]) (ident->text ident) - (#Meta [_ (#Tag ident)]) + (#Meta [_ (#TagS ident)]) (text:++ "#" (ident->text ident)) - (#Meta [_ (#Tuple members)]) + (#Meta [_ (#TupleS members)]) ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") - (#Meta [_ (#Form members)]) + (#Meta [_ (#FormS members)]) ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") - (#Meta [_ (#Record slots)]) + (#Meta [_ (#RecordS slots)]) ($ text:++ "{" (|> slots (map (_lux_: (-> (, Syntax Syntax) Text) @@ -1404,7 +1404,7 @@ (def__ #export (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux:Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1420,13 +1420,13 @@ [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] (;return (list ($form (list:join parts'))))))) - (#Meta [_ (#Form (#Cons [harg targs]))]) + (#Meta [_ (#FormS (#Cons [harg targs]))]) (do Lux:Monad [harg+ (macro-expand harg) targs+ (map% Lux:Monad macro-expand targs)] (;return (list ($form (list:++ harg+ (list:join targs+)))))) - (#Meta [_ (#Tuple members)]) + (#Meta [_ (#TupleS members)]) (do Lux:Monad [members' (map% Lux:Monad macro-expand members)] (;return (list ($tuple (list:join members'))))) @@ -1437,13 +1437,13 @@ (def__ (walk-type type) (-> Syntax Syntax) (_lux_case type - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) parts]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) ($form (#Cons [($tag tag) (map walk-type parts)])) - (#Meta [_ (#Tuple members)]) + (#Meta [_ (#TupleS members)]) ($tuple (map walk-type members)) - (#Meta [_ (#Form (#Cons [type-fn args]))]) + (#Meta [_ (#FormS (#Cons [type-fn args]))]) (fold (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) (walk-type type-fn) (map walk-type args)) @@ -1485,17 +1485,17 @@ (defmacro #export (deftype tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) [true tokens'] _ [false tokens])) parts (: (Maybe (, Syntax (List Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])]) + (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) (#Some [($symbol name) #Nil type]) - (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])]) + (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) (#Some [($symbol name) args type]) _ @@ -1546,20 +1546,20 @@ (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) [true tokens'] _ [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) (#Some [name args (#Some type) body]) (#Cons [name (#Cons [type (#Cons [body #Nil])])]) (#Some [name #Nil (#Some type) body]) - (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) (#Some [name args #None body]) (#Cons [name (#Cons [body #Nil])]) @@ -1605,7 +1605,7 @@ (lambda expander [branch] (let [[pattern body] branch] (_lux_case pattern - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) macro-args]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) (do Lux:Monad [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args))) expansions (map% Lux:Monad expander (as-pairs expansion))] @@ -1701,7 +1701,7 @@ (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" "_lux_:"])]) type (#Meta [_ (#Symbol name)])))])) + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) (do Lux:Monad [name' (normalize name)] (;return (: (, Ident Syntax) [name' type]))) @@ -1719,14 +1719,14 @@ (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (\ (list& (#Meta [_ (#Tag ["" "export"])]) tokens')) + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) (case tokens' - (\ (list& (#Meta [_ (#Form (list& name args))]) sigs)) + (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) (#Some [name args sigs]) (\ (list& name sigs)) @@ -1758,7 +1758,7 @@ (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#Form (list (#Meta [_ (#Symbol ["" "_lux_def"])]) (#Meta [_ (#Symbol name)]) value))])) + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) (do Lux:Monad [name' (normalize name)] (;return (: (, Syntax Syntax) [($tag name') value]))) @@ -1771,14 +1771,14 @@ (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (\ (list& (#Meta [_ (#Tag ["" "export"])]) tokens')) + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) (case tokens' - (\ (list& (#Meta [_ (#Form (list& name args))]) type defs)) + (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) (#Some [name args type defs]) (\ (list& name type defs)) @@ -1965,7 +1965,7 @@ (case tokens (\ (list struct body)) (case struct - (#Meta [_ (#Symbol vname)]) + (#Meta [_ (#SymbolS vname)]) (let [vname' (ident->text vname)] (case state {#source source #modules modules #module-aliases module-aliases @@ -2015,7 +2015,7 @@ ## (_lux_case tokens ## (#Cons [bindings (#Cons [body #Nil])]) ## (let [pairs (as-pairs bindings)] -## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["" "recur"])) (~ (#Tuple (map first pairs))) +## (return (list (#FormS (#Cons [(` (lambda (~ (#SymbolS ["" "recur"])) (~ (#TupleS (map first pairs))) ## (~ body))) ## (map second pairs)]))))))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index a47360ffb..c37c1acde 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -14,52 +14,52 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_catch"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?ex-class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?ex-arg]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_catch"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-arg]]]] ["lux;Cons" [?catch-body ["lux;Nil" _]]]]]]]]]]]]] (&/T (&/|++ catch+ (|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_finally"]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_finally"]]]] ["lux;Cons" [?finally-body ["lux;Nil" _]]]]]]]]] (&/T catch+ ?finally-body))) -(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;Tuple" (|list))))] +(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (|list))))] (defn ^:private aba1 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Standard special forms - [["lux;Meta" [meta ["lux;Bool" ?value]]]] + [["lux;Meta" [meta ["lux;BoolS" ?value]]]] (|do [_ (&type/check exo-type &type/Bool)] (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - [["lux;Meta" [meta ["lux;Int" ?value]]]] + [["lux;Meta" [meta ["lux;IntS" ?value]]]] (|do [_ (&type/check exo-type &type/Int)] (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - [["lux;Meta" [meta ["lux;Real" ?value]]]] + [["lux;Meta" [meta ["lux;RealS" ?value]]]] (|do [_ (&type/check exo-type &type/Real)] (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - [["lux;Meta" [meta ["lux;Char" ?value]]]] + [["lux;Meta" [meta ["lux;CharS" ?value]]]] (|do [_ (&type/check exo-type &type/Char)] (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - [["lux;Meta" [meta ["lux;Text" ?value]]]] + [["lux;Meta" [meta ["lux;TextS" ?value]]]] (|do [_ (&type/check exo-type &type/Text)] (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - [["lux;Meta" [meta ["lux;Tuple" ?elems]]]] + [["lux;Meta" [meta ["lux;TupleS" ?elems]]]] (&&lux/analyse-tuple analyse exo-type ?elems) - [["lux;Meta" [meta ["lux;Record" ?elems]]]] + [["lux;Meta" [meta ["lux;RecordS" ?elems]]]] (&&lux/analyse-record analyse exo-type ?elems) - [["lux;Meta" [meta ["lux;Tag" ?ident]]]] + [["lux;Meta" [meta ["lux;TagS" ?ident]]]] (&&lux/analyse-variant analyse exo-type ?ident unit) - [["lux;Meta" [meta ["lux;Symbol" [_ "_jvm_null"]]]]] + [["lux;Meta" [meta ["lux;SymbolS" [_ "_jvm_null"]]]]] (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) [_] @@ -68,50 +68,50 @@ (defn ^:private aba2 [analyse eval! exo-type token] (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;Symbol" ?ident]]]] + [["lux;Meta" [meta ["lux;SymbolS" ?ident]]]] (&&lux/analyse-symbol analyse exo-type ?ident) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_case"]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]] ["lux;Cons" [?value ?branches]]]]]]]] (&&lux/analyse-case analyse exo-type ?value ?branches) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_lambda"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?self]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?arg]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]]]]]] (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_def"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]] (&&lux/analyse-def analyse ?name ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_declare-macro"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] ["lux;Nil" _]]]]]]]]] (&&lux/analyse-declare-macro analyse ?name) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_import"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Text" ?path]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] ["lux;Nil" _]]]]]]]]] (&&lux/analyse-import analyse ?path) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_:"]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] ["lux;Cons" [?type ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]] (&&lux/analyse-check analyse eval! exo-type ?type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_:!"]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]] ["lux;Cons" [?type ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]] (&&lux/analyse-coerce analyse eval! ?type ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_lux_export"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?ident]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] ["lux;Nil" _]]]]]]]]] (&&lux/analyse-export analyse ?ident) @@ -122,53 +122,53 @@ (matchv ::M/objects [token] ;; Host special forms ;; Integer arithmetic - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-iadd analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-isub analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-imul analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-idiv analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-irem analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-ieq analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-ilt analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-igt analyse ?x ?y) ;; Long arithmetic - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-ladd analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lsub analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lmul analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-ldiv analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lrem analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-leq analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-llt analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lgt analyse ?x ?y) [_] @@ -177,53 +177,53 @@ (defn ^:private aba4 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Float arithmetic - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-fadd analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-fsub analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-fmul analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-fdiv analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-frem analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-feq analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-flt analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-fgt analyse ?x ?y) ;; Double arithmetic - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-dadd analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-dsub analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-dmul analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-ddiv analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-drem analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-deq analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-dlt analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-dgt analyse ?x ?y) [_] @@ -232,99 +232,99 @@ (defn ^:private aba5 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Objects - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_null?"]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] ["lux;Cons" [?object ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-null? analyse ?object) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_new"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-new analyse ?class ?classes ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_getstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getstatic"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-getstatic analyse ?class ?field) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_getfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getfield"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] ["lux;Cons" [?object ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-getfield analyse ?class ?field ?object) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_putstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putstatic"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-putstatic analyse ?class ?field ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_putfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?field]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putfield"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] ["lux;Cons" [?object ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]]]]]] (&&host/analyse-jvm-putfield analyse ?class ?field ?object ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_invokestatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokestatic"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]]]] (&&host/analyse-jvm-invokestatic analyse ?class ?method ?classes ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_invokevirtual"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokevirtual"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]]]]]] (&&host/analyse-jvm-invokevirtual analyse ?class ?method ?classes ?object ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_invokeinterface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokeinterface"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]]]]]] (&&host/analyse-jvm-invokeinterface analyse ?class ?method ?classes ?object ?args) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_invokespecial"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokespecial"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]]]]]] (&&host/analyse-jvm-invokespecial analyse ?class ?method ?classes ?object ?args) ;; Exceptions - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_try"]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]] ["lux;Cons" [?body ?handlers]]]]]]]] (&&host/analyse-jvm-try analyse ?body (&/fold parse-handler [(list) nil] ?handlers)) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_throw"]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] ["lux;Cons" [?ex ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-throw analyse ?ex) ;; Syncronization/monitos - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_monitorenter"]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorenter"]]]] ["lux;Cons" [?monitor ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-monitorenter analyse ?monitor) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_monitorexit"]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorexit"]]]] ["lux;Cons" [?monitor ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-monitorexit analyse ?monitor) @@ -335,74 +335,74 @@ (defn ^:private aba6 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Primitive conversions - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-d2f analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-d2i analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-d2l analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-f2d analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-f2i analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-f2l analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-i2b analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-i2c analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-i2d analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-i2f analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-i2l analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-i2s analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-l2d analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-l2f analyse ?value) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-l2i analyse ?value) ;; Bitwise operators - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-iand analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-ior analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-land analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lor analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lxor analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lshl analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lshr analyse ?x ?y) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-lushr analyse ?x ?y) [_] @@ -411,41 +411,41 @@ (defn ^:private aba7 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Arrays - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_new-array"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Int" ?length]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-new-array analyse ?class ?length) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_aastore"]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;Int" ?idx]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] ["lux;Cons" [?elem ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_aaload"]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;Int" ?idx]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_class"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?super-class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?fields]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?name]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?super-class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-class analyse ?name ?super-class ?fields) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_interface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?name]]]] ?members]]]]]]]] (&&host/analyse-jvm-interface analyse ?name ?members) ;; Programs - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?args]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?args]]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-program analyse ?args ?body) @@ -512,11 +512,11 @@ (defn ^:private analyse-ast [eval! exo-type token] (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?ident]]] ?values]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] (do (assert (= 1 (&/|length ?values)) "[Analyser Error] Can only tag 1 value.") (&&lux/analyse-variant (partial analyse-ast eval!) exo-type ?ident (&/|head ?values))) - [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [?fn ?args]]]]]] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] (fn [state] (matchv ::M/objects [((&type/with-var #(&&/analyse-1 (partial analyse-ast eval!) % ?fn)) state)] [["lux;Right" [state* =fn]]] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index f18dc7836..f27a541ee 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -22,38 +22,38 @@ (matchv ::M/objects [pattern] [["lux;Meta" [_ pattern*]]] (matchv ::M/objects [pattern*] - [["lux;Symbol" ?ident]] + [["lux;SymbolS" ?ident]] (|do [=kont (&env/with-local (&/ident->text ?ident) value-type kont) idx &env/next-local-idx] (return (&/T (&/V "StoreTestAC" idx) =kont))) - [["lux;Bool" ?value]] + [["lux;BoolS" ?value]] (|do [_ (&type/check value-type &type/Bool) =kont kont] (return (&/T (&/V "BoolTestAC" ?value) =kont))) - [["lux;Int" ?value]] + [["lux;IntS" ?value]] (|do [_ (&type/check value-type &type/Int) =kont kont] (return (&/T (&/V "IntTestAC" ?value) =kont))) - [["lux;Real" ?value]] + [["lux;RealS" ?value]] (|do [_ (&type/check value-type &type/Real) =kont kont] (return (&/T (&/V "RealTestAC" ?value) =kont))) - [["lux;Char" ?value]] + [["lux;CharS" ?value]] (|do [_ (&type/check value-type &type/Char) =kont kont] (return (&/T (&/V "CharTestAC" ?value) =kont))) - [["lux;Text" ?value]] + [["lux;TextS" ?value]] (|do [_ (&type/check value-type &type/Text) =kont kont] (return (&/T (&/V "TextTestAC" ?value) =kont))) - [["lux;Tuple" ?members]] + [["lux;TupleS" ?members]] (matchv ::M/objects [value-type] [["lux;TupleT" ?member-types]] (if (not (= (&/|length ?member-types) (&/|length ?members))) @@ -70,7 +70,7 @@ [_] (fail "[Analyser Error] Tuple requires tuple-type.")) - [["lux;Record" ?slots]] + [["lux;RecordS" ?slots]] (|do [value-type* (resolve-type value-type)] (matchv ::M/objects [value-type*] [["lux;RecordT" ?slot-types]] @@ -79,7 +79,7 @@ (|do [[=tests =kont] (&/fold (fn [kont* slot] (|let [[sn sv] slot] (matchv ::M/objects [sn] - [["lux;Meta" [_ ["lux;Tag" ?ident]]]] + [["lux;Meta" [_ ["lux;TagS" ?ident]]]] (|do [=tag (&&/resolved-ident ?ident)] (if-let [=slot-type (&/|get =tag ?slot-types)] (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] @@ -96,18 +96,18 @@ [_] (fail "[Analyser Error] Record requires record-type."))) - [["lux;Tag" ?ident]] + [["lux;TagS" ?ident]] (|do [=tag (&&/resolved-ident ?ident) value-type* (resolve-type value-type) case-type (&type/variant-case =tag value-type*) [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) - (&/V "lux;Tuple" (&/|list)))) + (&/V "lux;TupleS" (&/|list)))) kont)] (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) - [["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?ident]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]] (|do [=tag (&&/resolved-ident ?ident) value-type* (resolve-type value-type) case-type (&type/variant-case =tag value-type*) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 527c69dc7..9f80c43cc 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -12,7 +12,7 @@ ;; [Utils] (defn ^:private extract-ident [ident] (matchv ::M/objects [ident] - [["lux;Meta" [_ ["lux;Symbol" [_ ?ident]]]]] + [["lux;Meta" [_ ["lux;SymbolS" [_ ?ident]]]]] (return ?ident) [_] @@ -142,9 +142,9 @@ (defn analyse-jvm-class [analyse ?name ?super-class ?fields] (|do [?fields (&/map% (fn [?field] (matchv ::M/objects [?field] - [["lux;Meta" [_ ["lux;Tuple" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?field-name]]] - ["lux;Nil" _]]]]]]]]] + [["lux;Meta" [_ ["lux;TupleS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?field-name]]] + ["lux;Nil" _]]]]]]]]] (return [?class ?field-name]) [_] @@ -159,13 +159,13 @@ (defn analyse-jvm-interface [analyse ?name ?members] (|do [=members (&/map% (fn [member] (matchv ::M/objects [member] - [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ":"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "->"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?inputs]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?output]]]] - ["lux;Nil" _]]]]]]]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?member-name]]]] - ["lux;Nil" _]]]]]]]]]]] + [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ":"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "->"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?inputs]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?output]]]] + ["lux;Nil" _]]]]]]]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?member-name]]]] + ["lux;Nil" _]]]]]]]]]]] (|do [inputs* (&/map% extract-ident ?inputs)] (return [?member-name [inputs* ?output]])) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index b65963e4a..1b0c70f77 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -86,7 +86,7 @@ (fail "[Analyser Error] The type of a record must be a record type.")) =slots (&/map% (fn [kv] (matchv ::M/objects [kv] - [[["lux;Meta" [_ ["lux;Tag" ?ident]]] ?value]] + [[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]] (|do [?tag (&&/resolved-ident ?ident) slot-type (if-let [slot-type (&/|get ?tag types)] (return slot-type) diff --git a/src/lux/host.clj b/src/lux/host.clj index d159d2608..77687dbef 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -69,7 +69,7 @@ (defn extract-jvm-param [token] (matchv ::M/objects [token] - [["lux;Meta" [_ ["lux;Symbol" [_ ?ident]]]]] + [["lux;Meta" [_ ["lux;SymbolS" [_ ?ident]]]]] (return ?ident) [_] diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 6b392ea96..7a3ad18aa 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -17,8 +17,8 @@ [_] (fail (str "[Parser Error] Unbalanced " "."))))) - ^:private parse-form "Close_Paren" "parantheses" "lux;Form" - ^:private parse-tuple "Close_Bracket" "brackets" "lux;Tuple" + ^:private parse-form "Close_Paren" "parantheses" "lux;FormS" + ^:private parse-tuple "Close_Bracket" "brackets" "lux;TupleS" ) (defn ^:private parse-record [parse] @@ -28,7 +28,7 @@ (matchv ::M/objects [token] [["lux;Meta" [meta ["Close_Brace" _]]]] (if (even? (&/|length elems)) - (return (&/V "lux;Record" (&/|as-pairs elems))) + (return (&/V "lux;RecordS" (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) [_] @@ -47,25 +47,25 @@ (return (&/|list)) [["Bool" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Bool" (Boolean/parseBoolean ?value)))))) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value)))))) [["Int" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Int" (Integer/parseInt ?value)))))) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value)))))) [["Real" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Real" (Float/parseFloat ?value)))))) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value)))))) [["Char" ^String ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Char" (.charAt ?value 0)))))) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0)))))) [["Text" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Text" ?value))))) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value))))) [["Symbol" ?ident]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Symbol" ?ident))))) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident))))) [["Tag" ?ident]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;Tag" ?ident))))) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident))))) [["Open_Paren" _]] (|do [syntax (parse-form parse)] diff --git a/src/lux/type.clj b/src/lux/type.clj index 494d8ebbc..97b7c1bde 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -85,16 +85,16 @@ (&/V "lux;BoundT" "w"))))) Syntax*List (&/V "lux;AppT" (&/T List Syntax*))] (fAll "Syntax'" "w" - (&/V "lux;VariantT" (&/|list (&/T "lux;Bool" Bool) - (&/T "lux;Int" Int) - (&/T "lux;Real" Real) - (&/T "lux;Char" Char) - (&/T "lux;Text" Text) - (&/T "lux;Symbol" Ident) - (&/T "lux;Tag" Ident) - (&/T "lux;Form" Syntax*List) - (&/T "lux;Tuple" Syntax*List) - (&/T "lux;Record" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Syntax* Syntax*)))))) + (&/V "lux;VariantT" (&/|list (&/T "lux;BoolS" Bool) + (&/T "lux;IntS" Int) + (&/T "lux;RealS" Real) + (&/T "lux;CharS" Char) + (&/T "lux;TextS" Text) + (&/T "lux;SymbolS" Ident) + (&/T "lux;TagS" Ident) + (&/T "lux;FormS" Syntax*List) + (&/T "lux;TupleS" Syntax*List) + (&/T "lux;RecordS" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Syntax* Syntax*)))))) )))) (def Syntax -- cgit v1.2.3 From 279598fd1d5aace000231e4e85e5f9967634ce81 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 14 May 2015 07:46:30 -0400 Subject: - Multi-line comments have returned. --- src/lux/base.clj | 6 ------ src/lux/lexer.clj | 27 ++++++++++++++++++--------- src/lux/reader.clj | 48 ++++++++++++++++++++++++++++++++++++++++++++---- 3 files changed, 62 insertions(+), 19 deletions(-) diff --git a/src/lux/base.clj b/src/lux/base.clj index 3ac994043..9ea255132 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -32,18 +32,12 @@ (defn T [& elems] (to-array elems)) -;; (definline T [& elems] -;; `(to-array (list ~@elems))) (defn V [tag value] (to-array [tag value])) -;; (definline V [tag value] -;; `(to-array [~tag ~value])) (defn R [& kvs] (to-array kvs)) -;; (definline R [& kvs] -;; `(to-array (list ~@kvs))) (defn get$ [slot ^objects record] (aget record slot)) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 31258bc4b..2ee8088d3 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -35,23 +35,32 @@ (return (&/V "lux;Meta" (&/T meta (&/V "White_Space" white-space)))))) (def ^:private lex-single-line-comment - (|do [[_ [meta _]] (&reader/read-text "##") - [_ [_ comment]] (&reader/read-regex #"^(.*)$")] + (|do [_ (&reader/read-text "##") + [_ [meta comment]] (&reader/read-regex #"^(.*)$")] (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") - [meta comment] (&/try-all% (&/|list (|do [[_ [meta comment]] (&reader/read-regex #"(?is)^((?!#\().)*?(?=\)#)")] - (return comment)) - (|do [[_ [meta pre]] (&reader/read-regex #"(?is)^(.+?(?=#\())") - [_ inner] (lex-multi-line-comment nil) - [_ [_ post]] (&reader/read-regex #"(?is)^(.+?(?=\)#))")] - (return (str pre "#(" inner ")#" post))))) + [meta comment] (&/try-all% (&/|list (|do [[_ [meta comment]] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") + ;; :let [_ (prn 'immediate comment)] + _ (&reader/read-text ")#")] + (return (&/T meta comment))) + (|do [;; :let [_ (prn 'pre/_0)] + [_ [meta pre]] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") + ;; :let [_ (prn 'pre pre)] + [_ [_ [_ inner]]] (lex-multi-line-comment nil) + ;; :let [_ (prn 'inner inner)] + [_ [_ post]] (&reader/read-regex #"(?is)^(.+?(?=\)#))") + ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] + ] + (return (&/T meta (str pre "#(" inner ")#" post)))))) + ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) (def ^:private lex-comment - (&/try-all% (&/|list lex-single-line-comment))) + (&/try-all% (&/|list lex-single-line-comment + (lex-multi-line-comment nil)))) (do-template [ ] (def diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 69c95ea6a..c25870168 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -26,12 +26,28 @@ output)) ))) +(defn ^:private with-lines [body] + (fn [state] + (matchv ::M/objects [(body (&/get$ &/$SOURCE state))] + [["lux;Right" [reader* match]]] + (return* (&/set$ &/$SOURCE reader* state) + match) + + [["lux;Left" msg]] + (fail* msg) + ))) + ;; [Exports] (defn ^:private re-find! [^java.util.regex.Pattern regex line] (let [matcher (.matcher regex line)] (when (.find matcher) (.group matcher 0)))) +(defn ^:private re-find1! [^java.util.regex.Pattern regex line] + (let [matcher (.matcher regex line)] + (when (.find matcher) + (.group matcher 1)))) + (defn ^:private re-find3! [^java.util.regex.Pattern regex line] (let [matcher (.matcher regex line)] (when (.find matcher) @@ -42,10 +58,12 @@ (defn read-regex [regex] (with-line (fn [file-name line-num column-num ^String line] - (if-let [^String match (re-find! regex line)] - (let [match-length (.length match) + (if-let [^String match (do ;; (prn '[regex line] [regex line]) + (re-find! regex line))] + (let [;; _ (prn 'match match) + match-length (.length match) line* (.substring line match-length)] - (if (empty? line*) + (if (.isEmpty line*) (&/V "Done" (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match))) (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match)) (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))) @@ -57,12 +75,34 @@ (if-let [[^String match tok1 tok2] (re-find3! regex line)] (let [match-length (.length match) line* (.substring line match-length)] - (if (empty? line*) + (if (.isEmpty line*) (&/V "Done" (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)))) (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))) (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) +(defn read-regex+ [regex] + (with-lines + (fn [reader] + (loop [prefix "" + reader* reader] + (matchv ::M/objects [reader*] + [["lux;Nil" _]] + (&/V "lux;Left" "[Reader Error] EOF") + + [["lux;Cons" [[_ [[file-name line-num column-num] ^String line]] + reader**]]] + (if-let [^String match (do ;; (prn 'read-regex+ regex line) + (re-find1! regex line))] + (let [match-length (.length match) + line* (.substring line match-length)] + (if (.isEmpty line*) + (recur (str prefix match "\n") reader**) + (&/V "lux;Right" (&/T (&/|cons (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)) + reader**) + (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (str prefix match))))))) + (&/V "lux;Left" (str "[Reader Error] Pattern failed: " regex)))))))) + (defn read-text [^String text] (with-line (fn [file-name line-num column-num ^String line] -- cgit v1.2.3 From c4ac3e692ae96d6898d8efb42faf4dfadd43f4ae Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 14 May 2015 08:23:10 -0400 Subject: - Removed the apparently unnecessary total-locals. --- source/lux.lux | 46 ++++++++++++++------ source/program.lux | 2 +- src/lux.clj | 2 - src/lux/compiler/base.clj | 101 -------------------------------------------- src/lux/compiler/lambda.clj | 9 +--- 5 files changed, 36 insertions(+), 124 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 3b7bb9702..1385cf8a5 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1876,7 +1876,7 @@ [Int:Ord Int _jvm_llt _jvm_lgt _jvm_leq] [Real:Ord Real _jvm_dlt _jvm_dgt _jvm_deq]) -(defmacro #export (alias-lux tokens state) +(defmacro #export (lux tokens state) (case state {#source source #modules modules #module-aliases module-aliases #envs envs #types types #host host @@ -2005,12 +2005,42 @@ _ (let [dummy ($symbol ["" ""])] (#Right [state (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) (~ body)))))]))) + (~ dummy) + (using (~ dummy) (~ body)))))]))) _ (#Left "Wrong syntax for defsig"))) +(defmacro #export (when tokens) + (case tokens + (\ (list test body)) + (return (list (` (if (~ test) + (#Some (~ body)) + #None)))) + + _ + (fail "Wrong syntax for when"))) + +(def #export (flip f) + (All [a b c] + (-> (-> a b c) (-> b a c))) + (lambda [y x] + (f x y))) + +## (def #export (curry f) +## (All [a b c] +## (-> (-> (, a b) c) +## (-> a b c))) +## (lambda [x y] +## (f [x y]))) + +## (def #export (uncurry f) +## (All [a b c] +## (-> (-> a b c) +## (-> (, a b) c))) +## (lambda [[x y]] +## (f x y))) + ## (defmacro (loop tokens) ## (_lux_case tokens ## (#Cons [bindings (#Cons [body #Nil])]) @@ -2054,13 +2084,3 @@ ## (` (lambda [func record] ## (set@' (~ tag) (func (get@' (~ tag) record)) record))))] ## (return (list output)))) - -## (do-template [ ] -## (def ( pair) -## (All [a b] (-> (, a b) )) -## (case pair -## [f s] -## )) - -## [first f a] -## [second s b]) diff --git a/source/program.lux b/source/program.lux index 20f7863ab..a9451580f 100644 --- a/source/program.lux +++ b/source/program.lux @@ -1,4 +1,4 @@ -(;alias-lux) +(;lux) (def (filter p xs) (All [a] (-> (-> a Bool) (List a) (List a))) diff --git a/src/lux.clj b/src/lux.clj index 62e9d14f9..5b32955a3 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -9,7 +9,5 @@ (System/exit 0)) (comment - ;; TODO: Finish total-locals - ;; cd output && jar cvf program.jar * && java -cp "program.jar" program && cd .. ) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index c0a54ba53..a7886ab48 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -30,104 +30,3 @@ :let [_ (write-class name bytecode) _ (load-class! loader (string/replace name #"/" "."))]] (return nil))) - -(defn total-locals [expr] - (matchv ::M/objects [expr] - [[?struct ?type]] - (matchv ::M/objects [?struct] - [["case" [?variant ?base-register ?num-registers ?branches]]] - (+ ?num-registers (&/fold max 0 (&/|map (comp total-locals second) ?branches))) - - [["tuple" ?members]] - (&/fold max 0 (&/|map total-locals ?members)) - - [["variant" [?tag ?value]]] - (total-locals ?value) - - [["call" [?fn ?args]]] - (&/fold max 0 (&/|map total-locals (&/|cons ?fn ?args))) - - [["jvm-iadd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-isub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-imul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-idiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-irem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-ladd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-lsub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-lmul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-ldiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-lrem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fadd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fsub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fmul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-fdiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-frem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-dadd" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-dsub" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-dmul" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-ddiv" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["jvm-drem" [?x ?y]]] - (&/fold max 0 (&/|map total-locals (&/|list ?x ?y))) - - [["|do" ?exprs]] - (&/fold max 0 (&/|map total-locals ?exprs)) - - [["jvm-new" [?class ?classes ?args]]] - (&/fold max 0 (&/|map total-locals ?args)) - - [["jvm-invokestatic" [?class ?method ?classes ?args]]] - (&/fold max 0 (&/|map total-locals ?args)) - - [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] - (&/fold max 0 (&/|map total-locals ?args)) - - [["jvm-aastore" [?array ?idx ?elem]]] - (&/fold max 0 (&/|map total-locals (&/|list ?array ?elem))) - - [["jvm-aaload" [?array ?idx]]] - (total-locals ?array) - - ;; [["lambda" _]] - ;; 0 - - [_] - 0 - ))) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 625599617..42ed5459e 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -59,13 +59,8 @@ (&/with-writer (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) (.visitCode)) (|do [^MethodVisitor *writer* &/get-writer - :let [num-locals (&&/total-locals impl-body) - $start (new Label) - $end (new Label) - _ (doto *writer* - (-> (.visitLocalVariable (str &&/local-prefix idx) "Ljava/lang/Object;" nil $start $end (+ 2 idx)) - (->> (dotimes [idx num-locals]))) - (.visitLabel $start))] + :let [$start (new Label) + $end (new Label)] ret (compile impl-body) :let [_ (doto *writer* (.visitLabel $end) -- cgit v1.2.3 From f52eb6df2e57f67e7cf30d85c6340ce00f923d6f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 22 May 2015 20:07:08 -0400 Subject: - Corrected the indentation issues in the lux files. - Temporarily reverted back to forward apply-analysis. - Fixed an error in lux.base/show-ast. - Reader now only returns a tuple instead of a full-blown #Meta variant. - Reader now doesn't cut the strings that it reads. Instead, the "cursor" just moves around, indicating where to read. - Inlined some calculations that previously relied on try-all%. --- source/lux.lux | 2069 ++++++++++++++++++++++++---------------------- source/program.lux | 8 +- src/lux.clj | 5 +- src/lux/analyser.clj | 1 + src/lux/analyser/lux.clj | 86 +- src/lux/base.clj | 20 +- src/lux/compiler.clj | 4 +- src/lux/compiler/lux.clj | 9 +- src/lux/lexer.clj | 56 +- src/lux/reader.clj | 75 +- src/lux/type.clj | 128 ++- 11 files changed, 1301 insertions(+), 1160 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 1385cf8a5..e3f3ba243 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -37,22 +37,22 @@ ## (| #Nil ## (#Cons (, a (List a))))) (_lux_def List - (#AllT [#None "List" "a" - (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] - (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) - #Nil])]))] - #Nil])]))])) + (#AllT [#None "List" "a" + (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] + (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") + (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) + #Nil])]))] + #Nil])]))])) (_lux_export List) ## (deftype (Maybe a) ## (| #None ## (#Some a))) (_lux_def Maybe - (#AllT [#None "Maybe" "a" - (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] - (#Cons [["lux;Some" (#BoundT "a")] - #Nil])]))])) + (#AllT [#None "Maybe" "a" + (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] + (#Cons [["lux;Some" (#BoundT "a")] + #Nil])]))])) (_lux_export Maybe) ## (deftype #rec Type @@ -66,37 +66,37 @@ ## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) ## (#AppT (, Type Type)))) (_lux_def Type - (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) - Type - (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) - TypeEnv - (#AppT [(#AllT [#None "Type" "_" - (#VariantT (#Cons [["lux;DataT" Text] - (#Cons [["lux;TupleT" (#AppT [List Type])] - (#Cons [["lux;VariantT" TypeEnv] - (#Cons [["lux;RecordT" TypeEnv] - (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;BoundT" Text] - (#Cons [["lux;VarT" Int] - (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] - (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;ExT" Int] - #Nil])])])])])])])])])]))]) - Void])))) + (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) + Type + (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) + TypeEnv + (#AppT [(#AllT [#None "Type" "_" + (#VariantT (#Cons [["lux;DataT" Text] + (#Cons [["lux;TupleT" (#AppT [List Type])] + (#Cons [["lux;VariantT" TypeEnv] + (#Cons [["lux;RecordT" TypeEnv] + (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;BoundT" Text] + (#Cons [["lux;VarT" Int] + (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] + (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;ExT" Int] + #Nil])])])])])])])])])]))]) + Void])))) (_lux_export Type) ## (deftype (Bindings k v) ## (& #counter Int ## #mappings (List (, k v)))) (_lux_def Bindings - (#AllT [#None "Bindings" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;counter" Int] - (#Cons [["lux;mappings" (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))])] - #Nil])]))])])) + (#AllT [#None "Bindings" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;counter" Int] + (#Cons [["lux;mappings" (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))])] + #Nil])]))])])) ## (deftype (Env k v) ## (& #name Text @@ -104,30 +104,30 @@ ## #locals (Bindings k v) ## #closure (Bindings k v))) (_lux_def Env - (#AllT [#None "Env" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;name" Text] - (#Cons [["lux;inner-closures" Int] - (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - #Nil])])])]))])])) + (#AllT [#None "Env" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;name" Text] + (#Cons [["lux;inner-closures" Int] + (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + #Nil])])])]))])])) ## (deftype Cursor ## (, Text Int Int)) (_lux_def Cursor - (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) + (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) ## (deftype (Meta m v) ## (| (#Meta (, m v)))) (_lux_def Meta - (#AllT [#None "Meta" "m" - (#AllT [#None "" "v" - (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") - (#Cons [(#BoundT "v") - #Nil])]))] - #Nil]))])])) + (#AllT [#None "Meta" "m" + (#AllT [#None "" "v" + (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") + (#Cons [(#BoundT "v") + #Nil])]))] + #Nil]))])])) (_lux_export Meta) ## (deftype (Syntax' w) @@ -142,34 +142,34 @@ ## (#TupleS (List (w (Syntax' w)))) ## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) (_lux_def Syntax' - (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "Syntax'") - (#BoundT "w")])]) - Syntax - (_lux_case (#AppT [List Syntax]) - SyntaxList - (#AllT [#None "Syntax'" "w" - (#VariantT (#Cons [["lux;BoolS" Bool] - (#Cons [["lux;IntS" Int] - (#Cons [["lux;RealS" Real] - (#Cons [["lux;CharS" Char] - (#Cons [["lux;TextS" Text] - (#Cons [["lux;SymbolS" Ident] - (#Cons [["lux;TagS" Ident] - (#Cons [["lux;FormS" SyntaxList] - (#Cons [["lux;TupleS" SyntaxList] - (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] - #Nil]) - ])])])])])])])])]) - )])))) + (_lux_case (#AppT [(#BoundT "w") + (#AppT [(#BoundT "Syntax'") + (#BoundT "w")])]) + Syntax + (_lux_case (#AppT [List Syntax]) + SyntaxList + (#AllT [#None "Syntax'" "w" + (#VariantT (#Cons [["lux;BoolS" Bool] + (#Cons [["lux;IntS" Int] + (#Cons [["lux;RealS" Real] + (#Cons [["lux;CharS" Char] + (#Cons [["lux;TextS" Text] + (#Cons [["lux;SymbolS" Ident] + (#Cons [["lux;TagS" Ident] + (#Cons [["lux;FormS" SyntaxList] + (#Cons [["lux;TupleS" SyntaxList] + (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] + #Nil]) + ])])])])])])])])]) + )])))) (_lux_export Syntax') ## (deftype Syntax ## (Meta Cursor (Syntax' (Meta Cursor)))) (_lux_def Syntax - (_lux_case (#AppT [Meta Cursor]) - w - (#AppT [w (#AppT [Syntax' w])]))) + (_lux_case (#AppT [Meta Cursor]) + w + (#AppT [w (#AppT [Syntax' w])]))) (_lux_export Syntax) (_lux_def SyntaxList (#AppT [List Syntax])) @@ -178,39 +178,39 @@ ## (| (#Left l) ## (#Right r))) (_lux_def Either - (#AllT [#None "_" "l" - (#AllT [#None "" "r" - (#VariantT (#Cons [["lux;Left" (#BoundT "l")] - (#Cons [["lux;Right" (#BoundT "r")] - #Nil])]))])])) + (#AllT [#None "_" "l" + (#AllT [#None "" "r" + (#VariantT (#Cons [["lux;Left" (#BoundT "l")] + (#Cons [["lux;Right" (#BoundT "r")] + #Nil])]))])])) (_lux_export Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) (_lux_def StateE - (#AllT [#None "StateE" "s" - (#AllT [#None "" "a" - (#LambdaT [(#BoundT "s") - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [(#BoundT "s") - (#Cons [(#BoundT "a") - #Nil])]))])])])])) + (#AllT [#None "StateE" "s" + (#AllT [#None "" "a" + (#LambdaT [(#BoundT "s") + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [(#BoundT "s") + (#Cons [(#BoundT "a") + #Nil])]))])])])])) ## (deftype Reader ## (List (Meta Cursor Text))) (_lux_def Reader - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])])) + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])])) (_lux_export Reader) ## (deftype HostState ## (& #writer (^ org.objectweb.asm.ClassWriter) ## #loader (^ java.net.URLClassLoader))) (_lux_def HostState - (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] - (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - #Nil])]))) + (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] + (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] + #Nil])]))) ## (deftype (DefData' m) ## (| #TypeD @@ -218,20 +218,20 @@ ## (#MacroD m) ## (#AliasD Ident))) (_lux_def DefData' - (#AllT [#None "DefData'" "" - (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] - (#Cons [["lux;ValueD" Type] - (#Cons [["lux;MacroD" (#BoundT "")] - (#Cons [["lux;AliasD" Ident] - #Nil])])])]))])) + (#AllT [#None "DefData'" "" + (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] + (#Cons [["lux;ValueD" Type] + (#Cons [["lux;MacroD" (#BoundT "")] + (#Cons [["lux;AliasD" Ident] + #Nil])])])]))])) ## (deftype LuxVar ## (| (#Local Int) ## (#Global Ident))) (_lux_def LuxVar - (#VariantT (#Cons [["lux;Local" Int] - (#Cons [["lux;Global" Ident] - #Nil])]))) + (#VariantT (#Cons [["lux;Local" Int] + (#Cons [["lux;Global" Ident] + #Nil])]))) (_lux_export LuxVar) ## (deftype #rec CompilerState @@ -242,33 +242,33 @@ ## #types (Bindings Int Type) ## #host HostState)) (_lux_def CompilerState - (#AppT [(#AllT [#None "CompilerState" "" - (#RecordT (#Cons [["lux;source" Reader] - (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") - (#BoundT "")])]) - SyntaxList])])]) - #Nil])])) - #Nil])]))]) - #Nil])]))])] - (#Cons [["lux;module-aliases" (#AppT [List Void])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - (#Cons [["lux;seed" Int] - #Nil])])])])])])]))]) - Void])) + (#AppT [(#AllT [#None "CompilerState" "" + (#RecordT (#Cons [["lux;source" Reader] + (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") + (#BoundT "")])]) + SyntaxList])])]) + #Nil])])) + #Nil])]))]) + #Nil])]))])] + (#Cons [["lux;module-aliases" (#AppT [List Void])] + (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] + (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] + (#Cons [["lux;host" HostState] + (#Cons [["lux;seed" Int] + #Nil])])])])])])]))]) + Void])) (_lux_export CompilerState) ## (deftype Macro ## (-> (List Syntax) (StateE CompilerState (List Syntax)))) (_lux_def Macro - (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE CompilerState]) - SyntaxList])])) + (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE CompilerState]) + SyntaxList])])) (_lux_export Macro) ## Base functions & macros @@ -276,11 +276,11 @@ ## (-> (Syntax' (Meta Cursor)) Syntax) ## (#Meta [["" -1 -1] data])) (_lux_def _meta - (_lux_: (#LambdaT [(#AppT [Syntax' - (#AppT [Meta Cursor])]) - Syntax]) - (_lux_lambda _ data - (#Meta [["" -1 -1] data])))) + (_lux_: (#LambdaT [(#AppT [Syntax' + (#AppT [Meta Cursor])]) + Syntax]) + (_lux_lambda _ data + (#Meta [["" -1 -1] data])))) ## (def (return x) ## (All [a] @@ -288,16 +288,16 @@ ## (Either Text (, CompilerState a)))) ## ...) (_lux_def return - (_lux_: (#AllT [#None "" "a" - (#LambdaT [(#BoundT "a") - (#LambdaT [CompilerState - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (_lux_lambda _ val - (_lux_lambda _ state - (#Right [state val]))))) + (_lux_: (#AllT [#None "" "a" + (#LambdaT [(#BoundT "a") + (#LambdaT [CompilerState + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [CompilerState + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ val + (_lux_lambda _ state + (#Right [state val]))))) ## (def (fail msg) ## (All [a] @@ -305,260 +305,275 @@ ## (Either Text (, CompilerState a)))) ## ...) (_lux_def fail - (_lux_: (#AllT [#None "" "a" - (#LambdaT [Text - (#LambdaT [CompilerState - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (_lux_lambda _ msg - (_lux_lambda _ state - (#Left msg))))) + (_lux_: (#AllT [#None "" "a" + (#LambdaT [Text + (#LambdaT [CompilerState + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [CompilerState + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ msg + (_lux_lambda _ state + (#Left msg))))) (_lux_def $text - (_lux_: (#LambdaT [Text Syntax]) - (_lux_lambda _ text - (_meta (#TextS text))))) + (_lux_: (#LambdaT [Text Syntax]) + (_lux_lambda _ text + (_meta (#TextS text))))) (_lux_def $symbol - (_lux_: (#LambdaT [Ident Syntax]) - (_lux_lambda _ ident - (_meta (#SymbolS ident))))) + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#SymbolS ident))))) (_lux_def $tag - (_lux_: (#LambdaT [Ident Syntax]) - (_lux_lambda _ ident - (_meta (#TagS ident))))) + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#TagS ident))))) (_lux_def $form - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) - (_lux_lambda _ tokens - (_meta (#FormS tokens))))) + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#FormS tokens))))) (_lux_def $tuple - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) - (_lux_lambda _ tokens - (_meta (#TupleS tokens))))) + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#TupleS tokens))))) (_lux_def $record - (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) - (_lux_lambda _ tokens - (_meta (#RecordS tokens))))) + (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_lambda _ tokens + (_meta (#RecordS tokens))))) (_lux_def let' - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil])) - - _ - (fail "Wrong syntax for let'"))))) + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) + (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + #Nil]))) + + _ + (fail "Wrong syntax for let'"))))) (_lux_declare-macro let') (_lux_def lambda_ - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS ["" ""])) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS self)) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - _ - (fail "Wrong syntax for lambda"))))) + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS ["" ""])) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil]))) + + (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS self)) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil]))) + + _ + (fail "Wrong syntax for lambda"))))) (_lux_declare-macro lambda_) (_lux_def def_ - (_lux_: Macro - (lambda_ [tokens] - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil])) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil])) - - _ - (fail "Wrong syntax for def") - )))) + (_lux_: Macro + (lambda_ [tokens] + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])]))) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])]))) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + #Nil]))) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + #Nil]))) + + _ + (fail "Wrong syntax for def") + )))) (_lux_declare-macro def_) (def_ #export (defmacro tokens) Macro (_lux_case tokens - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (#Cons [($form (#Cons [($symbol ["lux" "def_"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])) - (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])])) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (#Cons [($form (#Cons [($symbol ["lux" "def_"]) - (#Cons [($tag ["" "export"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])])) - (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])])) - - _ - (fail "Wrong syntax for defmacro"))) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($form (#Cons [name args])) + (#Cons [($symbol ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])) + (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])]))) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($tag ["" "export"]) + (#Cons [($form (#Cons [name args])) + (#Cons [($symbol ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])])) + (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])]))) + + _ + (fail "Wrong syntax for defmacro"))) (_lux_declare-macro defmacro) (defmacro #export (comment tokens) - (return #Nil)) + (return (_lux_: SyntaxList #Nil))) (defmacro (->' tokens) (_lux_case tokens - (#Cons [input (#Cons [output #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil])) - - (#Cons [input (#Cons [output others])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for ->'"))) + (#Cons [input (#Cons [output #Nil])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil]))) + + (#Cons [input (#Cons [output others])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) + #Nil]))) + + _ + (fail "Wrong syntax for ->'"))) (defmacro (All' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS #Nil)]) - (#Cons [body #Nil])]) - (return (#Cons [body - #Nil])) - - (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) - (#Cons [body #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) - (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) - (#Cons [(_meta (#TextS "")) - (#Cons [(_meta (#TextS arg-name)) - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) - (#Cons [(_meta (#TupleS other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for All'"))) + (#Cons [(#Meta [_ (#TupleS #Nil)]) + (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#Cons [body + #Nil]))) + + (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) + (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) + (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) + (#Cons [(_meta (#TextS "")) + (#Cons [(_meta (#TextS arg-name)) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) + (#Cons [(_meta (#TupleS other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) + #Nil]))) + + _ + (fail "Wrong syntax for All'"))) (defmacro (B' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) - #Nil]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) - (#Cons [(_meta (#TextS bound-name)) - #Nil])]))) - #Nil])) + (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) + #Nil]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) + (#Cons [(_meta (#TextS bound-name)) + #Nil])]))) + #Nil]))) - _ - (fail "Wrong syntax for B'"))) + _ + (fail "Wrong syntax for B'"))) (defmacro ($' tokens) (_lux_case tokens - (#Cons [x #Nil]) - (return tokens) + (#Cons [x #Nil]) + (return tokens) + + (#Cons [x (#Cons [y xs])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) + (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) + #Nil]))) - (#Cons [x (#Cons [y xs])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) - (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil])) - - _ - (fail "Wrong syntax for $'"))) + _ + (fail "Wrong syntax for $'"))) (def_ #export (fold f init xs) (All' [a b] @@ -567,169 +582,182 @@ ($' List (B' b)) (B' a))) (_lux_case xs - #Nil - init + #Nil + init - (#Cons [x xs']) - (fold f (f init x) xs'))) + (#Cons [x xs']) + (fold f (f init x) xs'))) (def_ #export (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) - (fold (lambda_ [tail head] (#Cons [head tail])) + (fold (_lux_: (All' [a] + (->' ($' List (B' a)) (B' a) ($' List (B' a)))) + (lambda_ [tail head] + (#Cons [head tail]))) #Nil list)) (defmacro #export (list xs) - (return (#Cons [(fold (lambda_ [tail head] - (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) - (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) - (_meta (#TagS ["lux" "Nil"])) - (reverse xs)) - #Nil]))) + (return (_lux_: SyntaxList + (#Cons [(fold (lambda_ [tail head] + (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) + (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) + (_meta (#TagS ["lux" "Nil"])) + (reverse xs)) + #Nil])))) (defmacro #export (list& xs) (_lux_case (reverse xs) - (#Cons [last init]) - (return (list (fold (lambda_ [tail head] - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list head tail))))))) - last - init))) + (#Cons [last init]) + (return (_lux_: SyntaxList + (list (fold (lambda_ [tail head] + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) + last + init)))) - _ - (fail "Wrong syntax for list&"))) + _ + (fail "Wrong syntax for list&"))) (defmacro #export (lambda tokens) (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) - [name tokens'] + (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) + [name tokens'] - _ - [["" ""] tokens])) + _ + [["" ""] tokens])) (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case args - #Nil - (fail "lambda requires a non-empty arguments tuple.") - - (#Cons [harg targs]) - (return (list ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol name) - harg - (fold (lambda_ [body' arg] - ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol ["" ""]) - arg - body'))) - body - (reverse targs))))))) - - _ - (fail "Wrong syntax for lambda")))) + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case args + #Nil + (fail "lambda requires a non-empty arguments tuple.") + + (#Cons [harg targs]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_lambda"]) + ($symbol name) + harg + (fold (lambda_ [body' arg] + ($form (list ($symbol ["" "_lux_lambda"]) + ($symbol ["" ""]) + arg + body'))) + body + (reverse targs)))))))) + + _ + (fail "Wrong syntax for lambda")))) (defmacro (def__ tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))) - ($form (list ($symbol ["" "_lux_export"]) name)))) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - body)))) - ($form (list ($symbol ["" "_lux_export"]) name)))) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) type body)))))) - - _ - (fail "Wrong syntax for def") - )) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))) + ($form (list ($symbol ["" "_lux_export"]) name))))) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + body)))) + ($form (list ($symbol ["" "_lux_export"]) name))))) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body))))))))) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) type body))))))) + + _ + (fail "Wrong syntax for def") + )) (def__ (as-pairs xs) (All' [a] (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) (_lux_case xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) + (#Cons [x (#Cons [y xs'])]) + (#Cons [[x y] (as-pairs xs')]) - _ - #Nil)) + _ + #Nil)) (defmacro #export (let tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) - (return (list (fold (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (_lux_case binding - [label value] - (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) - body - (fold (lambda [tail head] (#Cons [head tail])) - #Nil - (as-pairs bindings))))) - - _ - (fail "Wrong syntax for let"))) + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (list (fold (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (_lux_case binding + [label value] + (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) + body + (fold (_lux_: (All' [a] + (->' ($' List (B' a)) (B' a) ($' List (B' a)))) + (lambda [tail head] (#Cons [head tail]))) + #Nil + (as-pairs bindings)))))) + + _ + (fail "Wrong syntax for let"))) (def__ #export (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs - #Nil - #Nil + #Nil + #Nil - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) + (#Cons [x xs']) + (#Cons [(f x) (map f xs')]))) (def__ #export (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) (_lux_case xs - #Nil - false + #Nil + false - (#Cons [x xs']) - (_lux_case (p x) - true true - false (any? p xs')))) + (#Cons [x xs']) + (_lux_case (p x) + true true + false (any? p xs')))) (def__ (spliced? token) (->' Syntax Bool) (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) - true + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) + true - _ - false)) + _ + false)) (def__ (wrap-meta content) (->' Syntax Syntax) @@ -740,141 +768,147 @@ (def__ (untemplate-list tokens) (->' ($' List Syntax) Syntax) (_lux_case tokens - #Nil - (_meta (#TagS ["lux" "Nil"])) + #Nil + (_meta (#TagS ["lux" "Nil"])) - (#Cons [token tokens']) - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list token (untemplate-list tokens'))))))))) + (#Cons [token tokens']) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list token (untemplate-list tokens'))))))))) (def__ (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) (_lux_case xs - (#Cons [x xs']) - (#Cons [x (list:++ xs' ys)]) + (#Cons [x xs']) + (#Cons [x (list:++ xs' ys)]) - #Nil - ys)) + #Nil + ys)) (defmacro #export ($ tokens) (_lux_case tokens - (#Cons [op (#Cons [init args])]) - (return (list (fold (lambda [a1 a2] ($form (list op a1 a2))) - init - args))) - - _ - (fail "Wrong syntax for $"))) + (#Cons [op (#Cons [init args])]) + (return (_lux_: SyntaxList + (list (fold (lambda [a1 a2] ($form (list op a1 a2))) + init + args)))) + + _ + (fail "Wrong syntax for $"))) (def__ (splice untemplate tag elems) (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) (_lux_case (any? spliced? elems) - true - (let [elems' (map (lambda [elem] - (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced - - _ - ($form (list ($symbol ["" "_lux_:"]) - ($symbol ["lux" "SyntaxList"]) - ($form (list ($symbol ["lux" "list"]) (untemplate elem))))))) - elems)] - (wrap-meta ($form (list tag - ($form (list& ($symbol ["lux" "$"]) - ($symbol ["lux" "list:++"]) - elems')))))) - - false - (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) + true + (let [elems' (map (_lux_: (->' Syntax Syntax) + (lambda [elem] + (_lux_case elem + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced + + _ + ($form (list ($symbol ["" "_lux_:"]) + ($symbol ["lux" "SyntaxList"]) + ($form (list ($symbol ["lux" "list"]) (untemplate elem)))))))) + elems)] + (wrap-meta ($form (list tag + ($form (list& ($symbol ["lux" "$"]) + ($symbol ["lux" "list:++"]) + elems')))))) + + false + (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) (def__ (untemplate subst token) (->' Text Syntax Syntax) (_lux_case token - (#Meta [_ (#BoolS value)]) - (wrap-meta ($form (list ($tag ["lux" "BoolS"]) (_meta (#BoolS value))))) + (#Meta [_ (#BoolS value)]) + (wrap-meta ($form (list ($tag ["lux" "BoolS"]) (_meta (#BoolS value))))) - (#Meta [_ (#IntS value)]) - (wrap-meta ($form (list ($tag ["lux" "IntS"]) (_meta (#IntS value))))) + (#Meta [_ (#IntS value)]) + (wrap-meta ($form (list ($tag ["lux" "IntS"]) (_meta (#IntS value))))) - (#Meta [_ (#RealS value)]) - (wrap-meta ($form (list ($tag ["lux" "RealS"]) (_meta (#RealS value))))) + (#Meta [_ (#RealS value)]) + (wrap-meta ($form (list ($tag ["lux" "RealS"]) (_meta (#RealS value))))) - (#Meta [_ (#CharS value)]) - (wrap-meta ($form (list ($tag ["lux" "CharS"]) (_meta (#CharS value))))) + (#Meta [_ (#CharS value)]) + (wrap-meta ($form (list ($tag ["lux" "CharS"]) (_meta (#CharS value))))) - (#Meta [_ (#TextS value)]) - (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value))))) + (#Meta [_ (#TextS value)]) + (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value))))) - (#Meta [_ (#TagS [module name])]) - (let [module' (_lux_case module - "" - subst + (#Meta [_ (#TagS [module name])]) + (let [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "TagS"]) ($tuple (list ($text module') ($text name))))))) + _ + module)] + (wrap-meta ($form (list ($tag ["lux" "TagS"]) ($tuple (list ($text module') ($text name))))))) - (#Meta [_ (#SymbolS [module name])]) - (let [module' (_lux_case module - "" - subst + (#Meta [_ (#SymbolS [module name])]) + (let [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "SymbolS"]) ($tuple (list ($text module') ($text name))))))) + _ + module)] + (wrap-meta ($form (list ($tag ["lux" "SymbolS"]) ($tuple (list ($text module') ($text name))))))) - (#Meta [_ (#TupleS elems)]) - (splice (untemplate subst) ($tag ["lux" "TupleS"]) elems) + (#Meta [_ (#TupleS elems)]) + (splice (untemplate subst) ($tag ["lux" "TupleS"]) elems) - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))]) - unquoted + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))]) + unquoted - (#Meta [_ (#FormS elems)]) - (splice (untemplate subst) ($tag ["lux" "FormS"]) elems) + (#Meta [_ (#FormS elems)]) + (splice (untemplate subst) ($tag ["lux" "FormS"]) elems) - (#Meta [_ (#RecordS fields)]) - (wrap-meta ($form (list ($tag ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) - (lambda [kv] - (let [[k v] kv] - ($tuple (list (untemplate subst k) (untemplate subst v)))))) - fields))))) - )) + (#Meta [_ (#RecordS fields)]) + (wrap-meta ($form (list ($tag ["lux" "RecordS"]) + (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) + (lambda [kv] + (let [[k v] kv] + ($tuple (list (untemplate subst k) (untemplate subst v)))))) + fields))))) + )) (defmacro (`' tokens) (_lux_case tokens - (#Cons [template #Nil]) - (return (list (untemplate "" template))) + (#Cons [template #Nil]) + (return (_lux_: SyntaxList + (list (untemplate "" template)))) - _ - (fail "Wrong syntax for `'"))) + _ + (fail "Wrong syntax for `'"))) (defmacro #export (|> tokens) (_lux_case tokens - (#Cons [init apps]) - (return (list (fold (lambda [acc app] - (_lux_case app - (#Meta [_ (#FormS parts)]) - ($form (list:++ parts (list acc))) + (#Cons [init apps]) + (return (_lux_: SyntaxList + (list (fold (_lux_: (->' Syntax Syntax Syntax) + (lambda [acc app] + (_lux_case app + (#Meta [_ (#FormS parts)]) + ($form (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc))))) - init - apps))) + _ + (`' ((~ app) (~ acc)))))) + init + apps)))) - _ - (fail "Wrong syntax for |>"))) + _ + (fail "Wrong syntax for |>"))) (defmacro #export (if tokens) (_lux_case tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (list (`' (_lux_case (~ test) - true (~ then) - false (~ else))))) + (#Cons [test (#Cons [then (#Cons [else #Nil])])]) + (return (_lux_: SyntaxList + (list (`' (_lux_case (~ test) + true (~ then) + false (~ else)))))) - _ - (fail "Wrong syntax for if"))) + _ + (fail "Wrong syntax for if"))) ## (deftype (Lux a) ## (-> CompilerState (Either Text (, CompilerState a)))) @@ -905,8 +939,8 @@ #lux;bind (lambda [f ma] (_lux_case ma - #None #None - (#Some a) (f a)))}) + #None #None + (#Some a) (f a)))}) (def__ Lux:Monad ($' Monad Lux) @@ -919,56 +953,61 @@ (lambda [f ma] (lambda [state] (_lux_case (ma state) - (#Left msg) - (#Left msg) + (#Left msg) + (#Left msg) - (#Right [state' a]) - (f a state'))))}) + (#Right [state' a]) + (f a state'))))}) (defmacro #export (^ tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) - (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) + (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) + (return (_lux_: SyntaxList + (list (`' (#;DataT (~ (_meta (#TextS class-name)))))))) - _ - (fail "Wrong syntax for ^"))) + _ + (fail "Wrong syntax for ^"))) (defmacro #export (-> tokens) (_lux_case (reverse tokens) - (#Cons [output inputs]) - (return (list (fold (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) - output - inputs))) - - _ - (fail "Wrong syntax for ->"))) + (#Cons [output inputs]) + (return (_lux_: SyntaxList + (list (fold (_lux_: (->' Syntax Syntax Syntax) + (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))) + output + inputs)))) + + _ + (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) - (return (list (`' (#;TupleT (;list (~@ tokens))))))) + (return (_lux_: SyntaxList + (list (`' (#;TupleT (;list (~@ tokens)))))))) (defmacro (do tokens) (_lux_case tokens - (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) - (let [body' (fold (_lux_: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (_lux_case var - (#Meta [_ (#TagS ["" "let"])]) - (`' (;let (~ value) (~ body'))) - - _ - (`' (;bind (_lux_lambda (~ ($symbol ["" ""])) - (~ var) - (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (return (list (`' (_lux_case (~ monad) - {#;return ;return #;bind ;bind} - (~ body')))))) - - _ - (fail "Wrong syntax for do"))) + (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) + (let [body' (fold (_lux_: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (_lux_case var + (#Meta [_ (#TagS ["" "let"])]) + (`' (;let (~ value) (~ body'))) + + _ + (`' (;bind (_lux_lambda (~ ($symbol ["" ""])) + (~ var) + (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (return (_lux_: SyntaxList + (list (`' (_lux_case (~ monad) + {#;return ;return #;bind ;bind} + (~ body'))))))) + + _ + (fail "Wrong syntax for do"))) (def__ (map% m f xs) ## (All [m a b] @@ -980,15 +1019,15 @@ ($' (B' m) ($' List (B' b))))) (let [{#;return ;return #;bind _} m] (_lux_case xs - #Nil - (;return #Nil) - - (#Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;return (#Cons [y ys]))) - ))) + #Nil + (;return (_lux_: List #Nil)) + + (#Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;return (_lux_: List (#Cons [y ys])))) + ))) (def__ #export (. f g) (All' [a b c] @@ -999,20 +1038,20 @@ (def__ (get-ident x) (-> Syntax ($' Maybe Text)) (_lux_case x - (#Meta [_ (#SymbolS ["" sname])]) - (#Some sname) + (#Meta [_ (#SymbolS ["" sname])]) + (#Some sname) - _ - #None)) + _ + #None)) (def__ (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) (_lux_case tuple - (#Meta [_ (#TupleS members)]) - (#Some members) + (#Meta [_ (#TupleS members)]) + (#Some members) - _ - #None)) + _ + #None)) (def__ RepEnv Type @@ -1022,11 +1061,11 @@ (-> ($' List Text) ($' List Syntax) RepEnv) (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) [xs ys]) - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (make-env xs' ys')]) + [(#Cons [x xs']) (#Cons [y ys'])] + (#Cons [[x y] (make-env xs' ys')]) - _ - #Nil)) + _ + #Nil)) (def__ (text:= x y) (-> Text Text Bool) @@ -1036,69 +1075,69 @@ (def__ (get-rep key env) (-> Text RepEnv ($' Maybe Syntax)) (_lux_case env - #Nil - #None + #Nil + #None - (#Cons [[k v] env']) - (if (text:= k key) - (#Some v) - (get-rep key env')))) + (#Cons [[k v] env']) + (if (text:= k key) + (#Some v) + (get-rep key env')))) (def__ (apply-template env template) (-> RepEnv Syntax Syntax) (_lux_case template - (#Meta [_ (#SymbolS ["" sname])]) - (_lux_case (get-rep sname env) - (#Some subst) - subst + (#Meta [_ (#SymbolS ["" sname])]) + (_lux_case (get-rep sname env) + (#Some subst) + subst - _ - template) + _ + template) - (#Meta [_ (#TupleS elems)]) - ($tuple (map (apply-template env) elems)) + (#Meta [_ (#TupleS elems)]) + ($tuple (map (apply-template env) elems)) - (#Meta [_ (#FormS elems)]) - ($form (map (apply-template env) elems)) + (#Meta [_ (#FormS elems)]) + ($form (map (apply-template env) elems)) - (#Meta [_ (#RecordS members)]) - ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [kv] - (let [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) - members)) + (#Meta [_ (#RecordS members)]) + ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [kv] + (let [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) + members)) - _ - template)) + _ + template)) (def__ (join-map f xs) (All' [a b] (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs - #Nil - #Nil + #Nil + #Nil - (#Cons [x xs']) - (list:++ (f x) (join-map f xs')))) + (#Cons [x xs']) + (list:++ (f x) (join-map f xs')))) (defmacro #export (do-template tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) - (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(map% Maybe:Monad get-ident bindings) - (map% Maybe:Monad tuple->list data)]) - [(#Some bindings') (#Some data')] - (let [apply (_lux_: (-> RepEnv ($' List Syntax)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - return)) - - _ - (fail "All the do-template bindigns must be symbols.")) - - _ - (fail "Wrong syntax for do-template"))) + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) + (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) + [(map% Maybe:Monad get-ident bindings) + (map% Maybe:Monad tuple->list data)]) + [(#Some bindings') (#Some data')] + (let [apply (_lux_: (-> RepEnv ($' List Syntax)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + return)) + + _ + (fail "All the do-template bindigns must be symbols.")) + + _ + (fail "Wrong syntax for do-template"))) (do-template [ ] [(def__ #export ( x y) @@ -1155,87 +1194,91 @@ (def__ (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) (_lux_case syntax - (#Meta [_ (#SymbolS ["" name])]) - (_lux_case (get-rep name reps) - (#Some replacement) - replacement + (#Meta [_ (#SymbolS ["" name])]) + (_lux_case (get-rep name reps) + (#Some replacement) + replacement - #None - syntax) - - (#Meta [_ (#FormS parts)]) - (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) - - (#Meta [_ (#TupleS members)]) - (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - - (#Meta [_ (#RecordS slots)]) - (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))]) - - _ - syntax) + #None + syntax) + + (#Meta [_ (#FormS parts)]) + (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) + + (#Meta [_ (#TupleS members)]) + (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) + + (#Meta [_ (#RecordS slots)]) + (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[k v] slot] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))]) + + _ + syntax) ) (defmacro #export (All tokens) (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) - [self-ident tokens'] + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) + [self-ident tokens'] - _ - ["" tokens]))] + _ + ["" tokens]))] (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe:Monad get-ident args) - (#Some idents) - (_lux_case idents - #Nil - (return (list body)) - - (#Cons [harg targs]) - (let [replacements (map (_lux_: (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) - (list& self-ident idents)) - body' (fold (lambda [body' arg'] (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))) - (replace-syntax replacements body) - (reverse targs))] - (return (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))) - - #None - (fail "'All' arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case (map% Maybe:Monad get-ident args) + (#Some idents) + (_lux_case idents + #Nil + (return (_lux_: SyntaxList + (list body))) + + (#Cons [harg targs]) + (let [replacements (map (_lux_: (-> Text (, Text Syntax)) + (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) + (list& self-ident idents)) + body' (fold (_lux_: (-> Syntax Text Syntax) + (lambda [body' arg'] + (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) + (replace-syntax replacements body) + (reverse targs))] + (return (_lux_: SyntaxList + (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) + + #None + (fail "'All' arguments must be symbols.")) + + _ + (fail "Wrong syntax for All")) )) (def__ (get k plist) (All [a] (-> Text ($' List (, Text a)) ($' Maybe a))) (_lux_case plist - (#Cons [[k' v] plist']) - (if (text:= k k') - (#Some v) - (get k plist')) + (#Cons [[k' v] plist']) + (if (text:= k k') + (#Some v) + (get k plist')) - #Nil - #None)) + #Nil + #None)) (def__ #export (get-module-name state) ($' Lux Text) (_lux_case state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (_lux_case (reverse envs) - #Nil - (#Left "Can't get the module name without a module!") + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (_lux_case (reverse envs) + #Nil + (#Left "Can't get the module name without a module!") - (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) - (#Right [state module-name])))) + (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Right [state module-name])))) (def__ (find-macro' modules current-module module name) (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE CompilerState ($' List Syntax))))))))) @@ -1245,18 +1288,18 @@ [bindings (get module modules) gdef (get name bindings)] (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) - [exported? (#MacroD macro')] - (if exported? - (#Some macro') - (if (text:= module current-module) - (#Some macro') - #None)) - - [_ (#AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) - - _ - #None))) + [exported? (#MacroD macro')] + (if exported? + (#Some macro') + (if (text:= module current-module) + (#Some macro') + #None)) + + [_ (#AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #None))) (def__ #export (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) @@ -1265,10 +1308,10 @@ (let [[module name] ident] (lambda [state] (_lux_case state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (#Right [state (find-macro' modules current-module module name)])))))) + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (#Right [state (find-macro' modules current-module module name)])))))) (def__ (list:join xs) (All [a] @@ -1288,20 +1331,20 @@ (def__ #export (normalize ident state) (-> Ident ($' Lux Ident)) (_lux_case ident - ["" name] - (_lux_case state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (_lux_case (reverse envs) - #Nil - (#Left "Can't normalize Ident without a global environment.") - - (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) - (#Right [state [prefix name]]))) - - _ - (#Right [state ident]))) + ["" name] + (_lux_case state + {#source source #modules modules #module-aliases module-aliases + #envs envs #types types #host host + #seed seed} + (_lux_case (reverse envs) + #Nil + (#Left "Can't normalize Ident without a global environment.") + + (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) + (#Right [state [prefix name]]))) + + _ + (#Right [state ident]))) (defmacro #export (| tokens) (do Lux:Monad @@ -1309,20 +1352,21 @@ (_lux_: (-> Syntax ($' Lux Syntax)) (lambda [token] (_lux_case token - (#Meta [_ (#TagS ident)]) - (do Lux:Monad - [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (;,)]))) - - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) - (do Lux:Monad - [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for |")))) + (#Meta [_ (#TagS ident)]) + (do Lux:Monad + [ident (normalize ident)] + (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (;,)])))) + + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) + (do Lux:Monad + [ident (normalize ident)] + (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + + _ + (fail "Wrong syntax for |")))) tokens)] - (;return (list (`' (#;VariantT (;list (~@ pairs)))))))) + (;return (_lux_: SyntaxList + (list (`' (#;VariantT (;list (~@ pairs))))))))) (defmacro #export (& tokens) (if (not (multiple? 2 (length tokens))) @@ -1332,15 +1376,16 @@ (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) (lambda [pair] (_lux_case pair - [(#Meta [_ (#TagS ident)]) value] - (do Lux:Monad - [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for &")))) + [(#Meta [_ (#TagS ident)]) value] + (do Lux:Monad + [ident (normalize ident)] + (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + + _ + (fail "Wrong syntax for &")))) (as-pairs tokens))] - (;return (list (`' (#;RecordT (;list (~@ pairs))))))))) + (;return (_lux_: SyntaxList + (list (`' (#;RecordT (;list (~@ pairs)))))))))) (def__ #export (->text x) (-> (^ java.lang.Object) Text) @@ -1350,174 +1395,179 @@ (All [a] (-> a ($' List a) ($' List a))) (_lux_case xs - #Nil - xs + #Nil + xs - (#Cons [x #Nil]) - xs + (#Cons [x #Nil]) + xs - (#Cons [x xs']) - (list& x sep (interpose sep xs')))) + (#Cons [x xs']) + (list& x sep (interpose sep xs')))) (def__ #export (syntax:show syntax) (-> Syntax Text) (_lux_case syntax - (#Meta [_ (#BoolS value)]) - (->text value) + (#Meta [_ (#BoolS value)]) + (->text value) - (#Meta [_ (#IntS value)]) - (->text value) + (#Meta [_ (#IntS value)]) + (->text value) - (#Meta [_ (#RealS value)]) - (->text value) + (#Meta [_ (#RealS value)]) + (->text value) - (#Meta [_ (#CharS value)]) - ($ text:++ "#\"" (->text value) "\"") + (#Meta [_ (#CharS value)]) + ($ text:++ "#\"" (->text value) "\"") - (#Meta [_ (#TextS value)]) - value + (#Meta [_ (#TextS value)]) + value - (#Meta [_ (#SymbolS ident)]) - (ident->text ident) + (#Meta [_ (#SymbolS ident)]) + (ident->text ident) - (#Meta [_ (#TagS ident)]) - (text:++ "#" (ident->text ident)) + (#Meta [_ (#TagS ident)]) + (text:++ "#" (ident->text ident)) - (#Meta [_ (#TupleS members)]) - ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") + (#Meta [_ (#TupleS members)]) + ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") - (#Meta [_ (#FormS members)]) - ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") + (#Meta [_ (#FormS members)]) + ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") - (#Meta [_ (#RecordS slots)]) - ($ text:++ "{" - (|> slots - (map (_lux_: (-> (, Syntax Syntax) Text) - (lambda [slot] - (let [[k v] slot] - ($ text:++ (syntax:show k) " " (syntax:show v)))))) - (interpose " ") - (fold text:++ "")) - "}") - )) + (#Meta [_ (#RecordS slots)]) + ($ text:++ "{" + (|> slots + (map (_lux_: (-> (, Syntax Syntax) Text) + (lambda [slot] + (let [[k v] slot] + ($ text:++ (syntax:show k) " " (syntax:show v)))))) + (interpose " ") + (fold text:++ "")) + "}") + )) (def__ #export (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) - (do Lux:Monad - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (_lux_case ?macro - (#Some macro) - (do Lux:Monad - [expansion (macro args) - expansion' (map% Lux:Monad macro-expand expansion)] - (;return (list:join expansion'))) - - #None - (do Lux:Monad - [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] - (;return (list ($form (list:join parts'))))))) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + (do Lux:Monad + [macro-name' (normalize macro-name) + ?macro (find-macro (_lux_: Ident macro-name'))] + (_lux_case (_lux_: ($' Maybe Macro) ?macro) + (#Some macro) + (do Lux:Monad + [expansion (macro args) + expansion' (map% Lux:Monad macro-expand (_lux_: SyntaxList expansion))] + (;return (_lux_: SyntaxList (list:join (_lux_: ($' List SyntaxList) expansion'))))) + + #None + (do Lux:Monad + [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] + (;return (_lux_: SyntaxList (list ($form (list:join (_lux_: ($' List SyntaxList) parts'))))))))) - (#Meta [_ (#FormS (#Cons [harg targs]))]) - (do Lux:Monad - [harg+ (macro-expand harg) - targs+ (map% Lux:Monad macro-expand targs)] - (;return (list ($form (list:++ harg+ (list:join targs+)))))) + (#Meta [_ (#FormS (#Cons [harg targs]))]) + (do Lux:Monad + [harg+ (macro-expand harg) + targs+ (map% Lux:Monad macro-expand (_lux_: SyntaxList targs))] + (;return (_lux_: SyntaxList (list ($form (list:++ harg+ (list:join (_lux_: ($' List SyntaxList) targs+)))))))) - (#Meta [_ (#TupleS members)]) - (do Lux:Monad - [members' (map% Lux:Monad macro-expand members)] - (;return (list ($tuple (list:join members'))))) + (#Meta [_ (#TupleS members)]) + (do Lux:Monad + [members' (map% Lux:Monad macro-expand members)] + (;return (_lux_: SyntaxList (list ($tuple (list:join (_lux_: ($' List SyntaxList) members'))))))) - _ - (return (list syntax)))) + _ + (return (_lux_: SyntaxList (list syntax))))) (def__ (walk-type type) (-> Syntax Syntax) (_lux_case type - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) - ($form (#Cons [($tag tag) (map walk-type parts)])) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + ($form (#Cons [($tag tag) (map walk-type parts)])) - (#Meta [_ (#TupleS members)]) - ($tuple (map walk-type members)) + (#Meta [_ (#TupleS members)]) + ($tuple (map walk-type members)) - (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (fold (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) - (walk-type type-fn) - (map walk-type args)) - - _ - type)) + (#Meta [_ (#FormS (#Cons [type-fn args]))]) + (fold (_lux_: (-> Syntax Syntax Syntax) + (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) + (walk-type type-fn) + (map walk-type args)) + + _ + type)) (defmacro #export (type` tokens) (_lux_case tokens - (#Cons [type #Nil]) - (do Lux:Monad - [type+ (macro-expand type)] - (_lux_case type+ - (#Cons [type' #Nil]) - (;return (list (walk-type type'))) - - _ - (fail "type`: The expansion of the type-syntax had to yield a single element."))) + (#Cons [type #Nil]) + (do Lux:Monad + [type+ (macro-expand type)] + (_lux_case (_lux_: SyntaxList type+) + (#Cons [type' #Nil]) + (;return (_lux_: SyntaxList + (list (walk-type type')))) + + _ + (fail "type`: The expansion of the type-syntax had to yield a single element."))) - _ - (fail "Wrong syntax for type`"))) + _ + (fail "Wrong syntax for type`"))) (defmacro #export (: tokens) (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (_lux_: (;type` (~ type)) (~ value))))) + (#Cons [type (#Cons [value #Nil])]) + (return (_lux_: SyntaxList + (list (`' (_lux_: (;type` (~ type)) (~ value)))))) - _ - (fail "Wrong syntax for :"))) + _ + (fail "Wrong syntax for :"))) (defmacro #export (:! tokens) (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (_lux_:! (;type` (~ type)) (~ value))))) + (#Cons [type (#Cons [value #Nil])]) + (return (_lux_: SyntaxList + (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) - _ - (fail "Wrong syntax for :!"))) + _ + (fail "Wrong syntax for :!"))) (defmacro #export (deftype tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] - _ - [false tokens])) + _ + [false tokens])) parts (: (Maybe (, Syntax (List Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) - (#Some [($symbol name) #Nil type]) + (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) + (#Some [($symbol name) #Nil type]) - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) - (#Some [($symbol name) args type]) + (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) + (#Some [($symbol name) args type]) - _ - #None))] + _ + #None))] (_lux_case parts - (#Some [name args type]) - (let [with-export (: (List Syntax) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)) - type' (: Syntax - (_lux_case args - #Nil - type - - _ - (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (list& (`' (_lux_def (~ name) (;type` (~ type')))) - with-export))) - - #None - (fail "Wrong syntax for deftype")) + (#Some [name args type]) + (let [with-export (: (List Syntax) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)) + type' (: Syntax + (_lux_case args + #Nil + type + + _ + (`' (;All (~ name) [(~@ args)] (~ type)))))] + (return (_lux_: SyntaxList + (list& (`' (_lux_def (~ name) (;type` (~ type')))) + with-export)))) + + #None + (fail "Wrong syntax for deftype")) )) (deftype #export (IO a) @@ -1525,71 +1575,75 @@ (defmacro #export (io tokens) (_lux_case tokens - (#Cons [value #Nil]) - (let [blank ($symbol ["" ""])] - (return (list (`' (_lux_lambda (~ blank) (~ blank) (~ value)))))) + (#Cons [value #Nil]) + (let [blank ($symbol ["" ""])] + (return (_lux_: SyntaxList + (list (`' (_lux_lambda (~ blank) (~ blank) (~ value))))))) - _ - (fail "Wrong syntax for io"))) + _ + (fail "Wrong syntax for io"))) (defmacro #export (exec tokens) (_lux_case (reverse tokens) - (#Cons [value actions]) - (let [dummy ($symbol ["" ""])] - (return (list (fold (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) - value - actions)))) + (#Cons [value actions]) + (let [dummy ($symbol ["" ""])] + (return (_lux_: SyntaxList + (list (fold (: (-> Syntax Syntax Syntax) + (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) + value + actions))))) - _ - (fail "Wrong syntax for exec"))) + _ + (fail "Wrong syntax for exec"))) (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] - _ - [false tokens])) + _ + [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (#Some [name args (#Some type) body]) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (#Some [name #Nil (#Some type) body]) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) - - (#Cons [name (#Cons [body #Nil])]) - (#Some [name #Nil #None body]) - - _ - #None))] + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) + (#Some [name args (#Some type) body]) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (#Some [name #Nil (#Some type) body]) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Some [name args #None body]) + + (#Cons [name (#Cons [body #Nil])]) + (#Some [name #Nil #None body]) + + _ + #None))] (_lux_case parts - (#Some [name args ?type body]) - (let [body' (: Syntax - (_lux_case args - #Nil - body - - _ - (`' (;lambda (~ name) [(~@ args)] (~ body))))) - body'' (: Syntax - (_lux_case ?type - (#Some type) - (`' (: (~ type) (~ body'))) - - #None - body'))] - (return (list& (`' (_lux_def (~ name) (~ body''))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for def")))) + (#Some [name args ?type body]) + (let [body' (: Syntax + (_lux_case args + #Nil + body + + _ + (`' (;lambda (~ name) [(~@ args)] (~ body))))) + body'' (: Syntax + (_lux_case ?type + (#Some type) + (`' (: (~ type) (~ body'))) + + #None + body'))] + (return (_lux_: SyntaxList + (list& (`' (_lux_def (~ name) (~ body''))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) + + #None + (fail "Wrong syntax for def")))) (def (rejoin-pair pair) (-> (, Syntax Syntax) (List Syntax)) @@ -1598,36 +1652,39 @@ (defmacro #export (case tokens) (_lux_case tokens - (#Cons [value branches]) - (do Lux:Monad - [expansions (map% Lux:Monad - (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) - (lambda expander [branch] - (let [[pattern body] branch] - (_lux_case pattern - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) - (do Lux:Monad - [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args))) - expansions (map% Lux:Monad expander (as-pairs expansion))] - (;return (list:join expansions))) - - _ - (;return (list branch)))))) - (as-pairs branches))] - (;return (list (`' (_lux_case (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) - - _ - (fail "Wrong syntax for case"))) + (#Cons [value branches]) + (do Lux:Monad + [expansions (map% Lux:Monad + (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) + (lambda expander [branch] + (let [[pattern body] branch] + (_lux_case pattern + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) + (do Lux:Monad + [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args))) + expansions (map% Lux:Monad expander (as-pairs (: (List Syntax) expansion)))] + (;return (: (List (, Syntax Syntax)) (list:join (: (List (List (, Syntax Syntax))) expansions))))) + + _ + (;return (: (List (, Syntax Syntax)) (list branch))))))) + (as-pairs branches))] + (;return (_lux_: SyntaxList + (list (`' (_lux_case (~ value) + (~@ (|> (: (List (List (, Syntax Syntax))) expansions) + list:join (map rejoin-pair) list:join)))))))) + + _ + (fail "Wrong syntax for case"))) (defmacro #export (\ tokens) (case tokens (#Cons [body (#Cons [pattern #Nil])]) (do Lux:Monad [pattern+ (macro-expand pattern)] - (case pattern+ + (case (: (List Syntax) pattern+) (#Cons [pattern' #Nil]) - (;return (list pattern' body)) + (;return (: (List Syntax) + (list pattern' body))) _ (fail "\\ can only expand to 1 pattern."))) @@ -1645,8 +1702,10 @@ _ (do Lux:Monad [patterns' (map% Lux:Monad macro-expand patterns)] - (;return (list:join (map (lambda [pattern] (list pattern body)) - (list:join patterns')))))) + (;return (_lux_: SyntaxList + (list:join (map (: (-> Syntax (List Syntax)) + (lambda [pattern] (list pattern body))) + (list:join patterns'))))))) _ (fail "Wrong syntax for \\or"))) @@ -1667,7 +1726,8 @@ [module-name get-module-name] (case tokens (\ (list template)) - (;return (list (untemplate module-name template))) + (;return (_lux_: SyntaxList + (list (untemplate module-name template)))) _ (fail "Wrong syntax for `")))) @@ -1687,7 +1747,7 @@ (-> Syntax (Lux Syntax)) (do Lux:Monad [token+ (macro-expand token)] - (case token+ + (case (: (List Syntax) token+) (\ (list token')) (;return token') @@ -1709,12 +1769,13 @@ _ (fail "Signatures require typed members!")))) tokens')] - (;return (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) - (lambda [pair] - (let [[name type] pair] - (`' [(~ (|> name ident->text $text)) - (~ type)])))) - members))))))))) + (;return (: (List Syntax) + (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) + (lambda [pair] + (let [[name type] pair] + (`' [(~ (|> name ident->text $text)) + (~ type)])))) + members)))))))))) (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1743,10 +1804,11 @@ _ (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (list& (`' (_lux_def (~ name) (~ sigs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) + (return (_lux_: SyntaxList + (list& (`' (_lux_def (~ name) (~ sigs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for defsig")))) @@ -1766,7 +1828,8 @@ _ (fail "Structures require defined members!")))) tokens')] - (;return (list ($record members))))) + (;return (_lux_: SyntaxList + (list ($record members)))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1795,10 +1858,11 @@ _ (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) + (return (_lux_: SyntaxList + (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for defsig")))) @@ -1847,9 +1911,11 @@ [(defmacro #export ( tokens) (case (reverse tokens) (\ (list& last init)) - (return (list (fold (lambda [post pre] (` )) - last - init))) + (return (: (List Syntax) + (list (fold (: (-> Syntax Syntax Syntax) + (lambda [post pre] (` ))) + last + init)))) _ (fail )))] @@ -1891,9 +1957,11 @@ (list name) (list))))) lux)] - (#Right [state (map (lambda [name] - (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name]))))) - (list:join to-alias))])) + (#Right [state (_lux_: SyntaxList + (map (: (-> Text Syntax) + (lambda [name] + (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) + (list:join to-alias)))])) #None (#Left "Uh, oh... The universe is not working properly...")) @@ -1997,16 +2065,18 @@ [($tag [module name]) ($symbol ["" name])]))) slots)) _ (println (text:++ "Using pattern: " (syntax:show pattern)))] - (#Right [state (list (` (_lux_case (~ struct) (~ pattern) (~ body))))])) + (#Right [state (_lux_: SyntaxList + (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) _ (#Left "Can only \"use\" records.")))))) _ (let [dummy ($symbol ["" ""])] - (#Right [state (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) (~ body)))))]))) + (#Right [state (_lux_: SyntaxList + (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) (~ body))))))]))) _ (#Left "Wrong syntax for defsig"))) @@ -2014,9 +2084,10 @@ (defmacro #export (when tokens) (case tokens (\ (list test body)) - (return (list (` (if (~ test) - (#Some (~ body)) - #None)))) + (return (_lux_: SyntaxList + (list (` (if (~ test) + (#Some (~ body)) + #None))))) _ (fail "Wrong syntax for when"))) diff --git a/source/program.lux b/source/program.lux index a9451580f..cefec07d4 100644 --- a/source/program.lux +++ b/source/program.lux @@ -12,7 +12,7 @@ (filter p xs')))) (_jvm_program _ - (exec (println "Hello, world!") - (|> (int:+ 2 2) ->text ($ text:++ "2 + 2 = ") println) - (println (->text (using Int:Ord - (< 5 10)))))) + (exec (println "Hello, world!") + (|> (int:+ 2 2) ->text ($ text:++ "2 + 2 = ") println) + (println (->text (using Int:Ord + (< 5 10)))))) diff --git a/src/lux.clj b/src/lux.clj index 5b32955a3..eb025f55e 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -2,10 +2,13 @@ (:gen-class) (:require [lux.base :as &] [lux.compiler :as &compiler] + [lux.type :as &type] :reload-all)) (defn -main [& _] - (time (&compiler/compile-all (&/|list "program"))) + (do (time (&compiler/compile-all (&/|list "program"))) + ;; (prn @&type/counter) + ) (System/exit 0)) (comment diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index c37c1acde..3c5c5c956 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -454,6 +454,7 @@ (fail ""))) (defn ^:private analyse-basic-ast [analyse eval! exo-type token] + ;; (prn 'analyse-basic-ast (&/show-ast token)) (fn [state] (matchv ::M/objects [((aba1 analyse eval! exo-type token) state)] [["lux;Right" [state* output]]] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 1b0c70f77..7600f34ff 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -151,7 +151,7 @@ [_] (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")) - (fail* "")) + (fail* "_{_ analyse-symbol _}_")) [["lux;Cons" [top-outer _]]] (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) @@ -172,39 +172,42 @@ ))) )) -(defn ^:private analyse-apply* [analyse exo-type fun-type args] - (matchv ::M/objects [args] - [["lux;Nil" _]] - (|do [_ (&type/check exo-type fun-type)] - (return (&/T (&/|list) fun-type))) - - [["lux;Cons" [?arg ?args*]]] - (|do [?fun-type* (&type/actual-type fun-type)] - (matchv ::M/objects [?fun-type*] - [["lux;AllT" _]] - (&type/with-var - (fn [$var] - (|do [type* (&type/apply-type ?fun-type* $var) - [?args** ?type**] (analyse-apply* analyse exo-type type* args)] - (matchv ::M/objects [$var] - [["lux;VarT" ?id]] - (|do [? (&type/bound? ?id) - _ (if ? - (return nil) - (|do [ex &type/existential] - (&type/set-var ?id ex))) - type*** (&type/clean $var ?type**)] - (return (&/T ?args** type***))) - )))) - - [["lux;LambdaT" [?input-t ?output-t]]] - (|do [[=args ?output-t*] (analyse-apply* analyse exo-type ?output-t ?args*) - =arg (&&/analyse-1 analyse ?input-t ?arg)] - (return (&/T (&/|cons =arg =args) ?output-t*))) +(defn ^:private analyse-apply* [analyse exo-type =fn ?args] + (matchv ::M/objects [=fn] + [[?fun-expr ?fun-type]] + (matchv ::M/objects [?args] + [["lux;Nil" _]] + (|do [_ (&type/check exo-type ?fun-type)] + (return =fn)) + + [["lux;Cons" [?arg ?args*]]] + (|do [?fun-type* (&type/actual-type ?fun-type)] + (matchv ::M/objects [?fun-type*] + [["lux;AllT" _]] + (&type/with-var + (fn [$var] + (|do [type* (&type/apply-type ?fun-type* $var) + output (analyse-apply* analyse exo-type (&/T ?fun-expr type*) ?args)] + (matchv ::M/objects [output $var] + [[?expr* ?type*] ["lux;VarT" ?id]] + (|do [? (&type/bound? ?id) + _ (if ? + (return nil) + (|do [ex &type/existential] + (&type/set-var ?id ex))) + type** (&type/clean $var ?type*)] + (return (&/T ?expr* type**))) + )))) + + [["lux;LambdaT" [?input-t ?output-t]]] + (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)] + (analyse-apply* analyse exo-type (&/T (&/V "apply" (&/T =fn =arg)) + ?output-t) + ?args*)) - [_] - (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) - )) + [_] + (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) + ))) (defn analyse-apply [analyse exo-type =fn ?args] (|do [loader &/loader] @@ -219,14 +222,12 @@ (&/flat-map% (partial analyse exo-type) macro-expansion)) [_] - (|do [[=args =app-type] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) - =app-type)))))) + (|do [output (analyse-apply* analyse exo-type =fn ?args)] + (return (&/|list output))))) [_] - (|do [[=args =app-type] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) - =app-type))))) + (|do [output (analyse-apply* analyse exo-type =fn ?args)] + (return (&/|list output)))) ))) (defn analyse-case [analyse exo-type ?value ?branches] @@ -263,7 +264,12 @@ (|do [? (&type/bound? ?id)] (if ? (|do [dtype (&type/deref ?id)] - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype)))) + (matchv ::M/objects [dtype] + [["lux;ExT" _]] + (return (&/T _expr exo-type)) + + [_] + (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) (return (&/T _expr exo-type)))))))) [_] diff --git a/src/lux/base.clj b/src/lux/base.clj index 9ea255132..edf6781ea 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -551,40 +551,40 @@ (defn show-ast [ast] (matchv ::M/objects [ast] - [["lux;Meta" [_ ["lux;Bool" ?value]]]] + [["lux;Meta" [_ ["lux;BoolS" ?value]]]] (pr-str ?value) - [["lux;Meta" [_ ["lux;Int" ?value]]]] + [["lux;Meta" [_ ["lux;IntS" ?value]]]] (pr-str ?value) - [["lux;Meta" [_ ["lux;Real" ?value]]]] + [["lux;Meta" [_ ["lux;RealS" ?value]]]] (pr-str ?value) - [["lux;Meta" [_ ["lux;Char" ?value]]]] + [["lux;Meta" [_ ["lux;CharS" ?value]]]] (pr-str ?value) - [["lux;Meta" [_ ["lux;Text" ?value]]]] + [["lux;Meta" [_ ["lux;TextS" ?value]]]] (str "\"" ?value "\"") - [["lux;Meta" [_ ["lux;Tag" [?module ?tag]]]]] + [["lux;Meta" [_ ["lux;TagS" [?module ?tag]]]]] (str "#" ?module ";" ?tag) - [["lux;Meta" [_ ["lux;Symbol" [?module ?ident]]]]] + [["lux;Meta" [_ ["lux;SymbolS" [?module ?ident]]]]] (if (= "" ?module) ?ident (str ?module ";" ?ident)) - [["lux;Meta" [_ ["lux;Tuple" ?elems]]]] + [["lux;Meta" [_ ["lux;TupleS" ?elems]]]] (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - [["lux;Meta" [_ ["lux;Record" ?elems]]]] + [["lux;Meta" [_ ["lux;RecordS" ?elems]]]] (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - [["lux;Meta" [_ ["lux;Form" ?elems]]]] + [["lux;Meta" [_ ["lux;FormS" ?elems]]]] (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") )) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 26b75bec3..6fb9e2c6d 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -60,8 +60,8 @@ [["lux;Global" [?owner-class ?name]]] (&&lux/compile-global compile-expression ?type ?owner-class ?name) - [["apply" [?fn ?args]]] - (&&lux/compile-apply compile-expression ?type ?fn ?args) + [["apply" [?fn ?arg]]] + (&&lux/compile-apply compile-expression ?type ?fn ?arg) [["variant" [?tag ?members]]] (&&lux/compile-variant compile-expression ?type ?tag ?members) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 2c5073a4d..cf4a65f04 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -117,14 +117,11 @@ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (&/|list ?owner-class ?name))) "_datum" "Ljava/lang/Object;")]] (return nil))) -(defn compile-apply [compile *type* ?fn ?args] +(defn compile-apply [compile *type* ?fn ?arg] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?fn) - _ (&/map% (fn [?arg] - (|do [_ (compile ?arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature)]] - (return nil))) - ?args)] + _ (compile ?arg) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature)]] (return nil))) (defn compile-def [compile ?name ?body ?def-data] diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 2ee8088d3..d2ab4a5d7 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -18,11 +18,11 @@ (fail (str "[Lexer Error] Unknown escape character: " escaped)))) (defn ^:private lex-text-body [_] - (&/try-all% (&/|list (|do [[_ [_ [prefix escaped]]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)") + (&/try-all% (&/|list (|do [[_ [prefix escaped]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)") unescaped (escape-char escaped) postfix (lex-text-body nil)] (return (str prefix unescaped postfix))) - (|do [[_ [_ body]] (&reader/read-regex #"(?s)^([^\"\\]*)")] + (|do [[_ body] (&reader/read-regex #"(?s)^([^\"\\]*)")] (return body))))) (def ^:private +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'`:\~\?]*)" @@ -31,26 +31,26 @@ ;; [Lexers] (def ^:private lex-white-space - (|do [[_ [meta white-space]] (&reader/read-regex #"^(\s+)")] + (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] (return (&/V "lux;Meta" (&/T meta (&/V "White_Space" white-space)))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") - [_ [meta comment]] (&reader/read-regex #"^(.*)$")] + [meta comment] (&reader/read-regex #"^(.*)$")] (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") - [meta comment] (&/try-all% (&/|list (|do [[_ [meta comment]] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") + [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") ;; :let [_ (prn 'immediate comment)] _ (&reader/read-text ")#")] (return (&/T meta comment))) (|do [;; :let [_ (prn 'pre/_0)] - [_ [meta pre]] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") + [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") ;; :let [_ (prn 'pre pre)] - [_ [_ [_ inner]]] (lex-multi-line-comment nil) + [_ inner] (lex-multi-line-comment nil) ;; :let [_ (prn 'inner inner)] - [_ [_ post]] (&reader/read-regex #"(?is)^(.+?(?=\)#))") + [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))") ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] ] (return (&/T meta (str pre "#(" inner ")#" post)))))) @@ -64,7 +64,7 @@ (do-template [ ] (def - (|do [[_ [meta token]] (&reader/read-regex )] + (|do [[meta token] (&reader/read-regex )] (return (&/V "lux;Meta" (&/T meta (&/V token)))))) ^:private lex-bool "Bool" #"^(true|false)" @@ -73,54 +73,54 @@ ) (def ^:private lex-char - (|do [[_ [meta _]] (&reader/read-text "#\"") - token (&/try-all% (&/|list (|do [[_ [_ escaped]] (&reader/read-regex #"^(\\.)")] + (|do [[meta _] (&reader/read-text "#\"") + token (&/try-all% (&/|list (|do [[_ escaped] (&reader/read-regex #"^(\\.)")] (escape-char escaped)) - (|do [[_ [_ char]] (&reader/read-regex #"^(.)")] + (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] (return (&/V "lux;Meta" (&/T meta (&/V "Char" token)))))) (def ^:private lex-text - (|do [[_ [meta _]] (&reader/read-text "\"") + (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] (return (&/V "lux;Meta" (&/T meta (&/V "Text" token)))))) (def ^:private lex-ident - (&/try-all% (&/|list (|do [[_ [meta token]] (&reader/read-regex +ident-re+)] + (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] (&/try-all% (&/|list (|do [_ (&reader/read-text ";") - [_ [_ local-token]] (&reader/read-regex +ident-re+)] + [_ local-token] (&reader/read-regex +ident-re+)] (&/try-all% (&/|list (|do [unaliased (&module/dealias token)] - (return (&/V "lux;Meta" (&/T meta (&/T unaliased local-token))))) + (return (&/T meta (&/T unaliased local-token)))) (|do [? (&module/exists? token)] (if ? - (return (&/V "lux;Meta" (&/T meta (&/T token local-token)))) + (return (&/T meta (&/T token local-token))) (fail (str "[Lexer Error] Unknown module: " token)))) ))) - (return (&/V "lux;Meta" (&/T meta (&/T "" token)))) + (return (&/T meta (&/T "" token))) ))) - (|do [[_ [meta _]] (&reader/read-text ";;") - [_ [_ token]] (&reader/read-regex +ident-re+) + (|do [[meta _] (&reader/read-text ";;") + [_ token] (&reader/read-regex +ident-re+) module-name &/get-module-name] - (return (&/V "lux;Meta" (&/T meta (&/T module-name token))))) - (|do [[_ [meta _]] (&reader/read-text ";") - [_ [_ token]] (&reader/read-regex +ident-re+)] - (return (&/V "lux;Meta" (&/T meta (&/T "lux" token))))) + (return (&/T meta (&/T module-name token)))) + (|do [[meta _] (&reader/read-text ";") + [_ token] (&reader/read-regex +ident-re+)] + (return (&/T meta (&/T "lux" token)))) ))) (def ^:private lex-symbol - (|do [[_ [meta ident]] lex-ident] + (|do [[meta ident] lex-ident] (return (&/V "lux;Meta" (&/T meta (&/V "Symbol" ident)))))) (def ^:private lex-tag - (|do [[_ [meta _]] (&reader/read-text "#") - [_ [_ ident]] lex-ident] + (|do [[meta _] (&reader/read-text "#") + [_ ident] lex-ident] (return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident)))))) (do-template [ ] (def - (|do [[_ [meta _]] (&reader/read-text )] + (|do [[meta _] (&reader/read-text )] (return (&/V "lux;Meta" (&/T meta (&/V nil)))))) ^:private lex-open-paren "(" "Open_Paren" diff --git a/src/lux/reader.clj b/src/lux/reader.clj index c25870168..b1fcc4740 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -11,7 +11,7 @@ [["lux;Nil" _]] (fail* "[Reader Error] EOF") - [["lux;Cons" [["lux;Meta" [[file-name line-num column-num] line]] + [["lux;Cons" [[[file-name line-num column-num] line] more]]] (matchv ::M/objects [(body file-name line-num column-num line)] [["No" msg]] @@ -38,18 +38,24 @@ ))) ;; [Exports] -(defn ^:private re-find! [^java.util.regex.Pattern regex line] - (let [matcher (.matcher regex line)] +(defn ^:private re-find! [^java.util.regex.Pattern regex column ^String line] + (let [matcher (doto (.matcher regex line) + (.region column (.length line)) + (.useAnchoringBounds true))] (when (.find matcher) (.group matcher 0)))) -(defn ^:private re-find1! [^java.util.regex.Pattern regex line] - (let [matcher (.matcher regex line)] +(defn ^:private re-find1! [^java.util.regex.Pattern regex column ^String line] + (let [matcher (doto (.matcher regex line) + (.region column (.length line)) + (.useAnchoringBounds true))] (when (.find matcher) (.group matcher 1)))) -(defn ^:private re-find3! [^java.util.regex.Pattern regex line] - (let [matcher (.matcher regex line)] +(defn ^:private re-find3! [^java.util.regex.Pattern regex column ^String line] + (let [matcher (doto (.matcher regex line) + (.region column (.length line)) + (.useAnchoringBounds true))] (when (.find matcher) (list (.group matcher 0) (.group matcher 1) @@ -58,27 +64,29 @@ (defn read-regex [regex] (with-line (fn [file-name line-num column-num ^String line] + ;; (prn 'read-regex [file-name line-num column-num regex line]) (if-let [^String match (do ;; (prn '[regex line] [regex line]) - (re-find! regex line))] + (re-find! regex column-num line))] (let [;; _ (prn 'match match) match-length (.length match) - line* (.substring line match-length)] - (if (.isEmpty line*) - (&/V "Done" (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match))) - (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) match)) - (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))) + 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)))))) (defn read-regex2 [regex] (with-line (fn [file-name line-num column-num ^String line] - (if-let [[^String match tok1 tok2] (re-find3! regex line)] + ;; (prn 'read-regex2 [file-name line-num column-num regex line]) + (if-let [[^String match tok1 tok2] (re-find3! regex column-num line)] (let [match-length (.length match) - line* (.substring line match-length)] - (if (.isEmpty line*) - (&/V "Done" (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)))) - (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) - (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))) + 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)))))) (defn read-regex+ [regex] @@ -90,37 +98,38 @@ [["lux;Nil" _]] (&/V "lux;Left" "[Reader Error] EOF") - [["lux;Cons" [[_ [[file-name line-num column-num] ^String line]] + [["lux;Cons" [[[file-name line-num column-num] ^String line] reader**]]] (if-let [^String match (do ;; (prn 'read-regex+ regex line) - (re-find1! regex line))] + (re-find1! regex column-num line))] (let [match-length (.length match) - line* (.substring line match-length)] - (if (.isEmpty line*) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) - (&/V "lux;Right" (&/T (&/|cons (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)) + (&/V "lux;Right" (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) reader**) - (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) (str prefix match))))))) + (&/T (&/T file-name line-num column-num) (str prefix match)))))) (&/V "lux;Left" (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] (with-line (fn [file-name line-num column-num ^String line] - (if (.startsWith line text) + ;; (prn 'read-text [file-name line-num column-num text line]) + (if (.startsWith line text column-num) (let [match-length (.length text) - line* (.substring line match-length)] - (if (empty? line*) - (&/V "Done" (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) text))) - (&/V "Yes" (&/T (&/V "lux;Meta" (&/T (&/T file-name line-num column-num) text)) - (&/V "lux;Meta" (&/T (&/T file-name line-num (+ column-num match-length)) line*)))))) + 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)))))) (defn from [file-name] (let [lines (&/->list (string/split-lines (slurp file-name)))] (&/|map (fn [line+line-num] (|let [[line-num line] line+line-num] - (&/V "lux;Meta" (&/T (&/T file-name line-num 0) - line)))) + (&/T (&/T file-name line-num 0) + line))) (&/|filter (fn [line+line-num] (|let [[line-num line] line+line-num] (not= "" line))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 97b7c1bde..105528b8a 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -547,17 +547,28 @@ (def init-fixpoints (&/|list)) +(def counter (atom {})) (defn ^:private check* [fixpoints expected actual] + ;; (swap! counter update-in [[(aget expected 0) (aget actual 0)]] + ;; #(inc (or % 0))) (matchv ::M/objects [expected actual] [["lux;VarT" ?eid] ["lux;VarT" ?aid]] (if (= ?eid ?aid) (return (&/T fixpoints nil)) - (|do [ebound (&/try-all% (&/|list (|do [ebound (deref ?eid)] - (return (&/V "lux;Some" ebound))) - (return (&/V "lux;None" nil)))) - abound (&/try-all% (&/|list (|do [abound (deref ?aid)] - (return (&/V "lux;Some" abound))) - (return (&/V "lux;None" nil))))] + (|do [ebound (fn [state] + (matchv ::M/objects [((deref ?eid) state)] + [["lux;Right" [state* ebound]]] + (return* state* (&/V "lux;Some" ebound)) + + [["lux;Left" _]] + (return* state (&/V "lux;None" nil)))) + abound (fn [state] + (matchv ::M/objects [((deref ?aid) state)] + [["lux;Right" [state* abound]]] + (return* state* (&/V "lux;Some" abound)) + + [["lux;Left" _]] + (return* state (&/V "lux;None" nil))))] (matchv ::M/objects [ebound abound] [["lux;None" _] ["lux;None" _]] (|do [_ (set-var ?eid actual)] @@ -573,39 +584,75 @@ (check* fixpoints etype atype)))) [["lux;VarT" ?id] _] - (&/try-all% (&/|list (|do [_ (set-var ?id actual)] - (return (&/T fixpoints nil))) - (|do [bound (deref ?id)] - (check* fixpoints bound actual)))) + (fn [state] + (matchv ::M/objects [((set-var ?id actual) state)] + [["lux;Right" [state* _]]] + (return* state* (&/T fixpoints nil)) + + [["lux;Left" _]] + ((|do [bound (deref ?id)] + (check* fixpoints bound actual)) + state))) [_ ["lux;VarT" ?id]] - (&/try-all% (&/|list (|do [_ (set-var ?id expected)] - (return (&/T fixpoints nil))) - (|do [bound (deref ?id)] - (check* fixpoints expected bound)))) + (fn [state] + (matchv ::M/objects [((set-var ?id expected) state)] + [["lux;Right" [state* _]]] + (return* state* (&/T fixpoints nil)) + + [["lux;Left" _]] + ((|do [bound (deref ?id)] + (check* fixpoints expected bound)) + state))) [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] - (&/try-all% (&/|list (|do [F1 (deref ?eid)] - (&/try-all% (&/|list (|do [F2 (deref ?aid)] - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)))) - (|do [F2 (deref ?aid)] - (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - [fixpoints** _] (check* fixpoints* A1 A2)] - (return (&/T fixpoints** nil))))) + (fn [state] + (matchv ::M/objects [((|do [F1 (deref ?eid)] + (fn [state] + (matchv ::M/objects [((|do [F2 (deref ?aid)] + (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + ((check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + state)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + (matchv ::M/objects [((|do [F2 (deref ?aid)] + (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + [fixpoints** _] (check* fixpoints* A1 A2)] + (return (&/T fixpoints** nil))) + state)))) ;; (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) ;; _ (check* fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - (&/try-all% (&/|list (|do [F1 (deref ?id)] - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) - (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) - e* (apply-type F2 A1) - a* (apply-type F2 A2) - [fixpoints** _] (check* fixpoints* e* a*)] - (return (&/T fixpoints** nil))))) + (fn [state] + (matchv ::M/objects [((|do [F1 (deref ?id)] + (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + e* (apply-type F2 A1) + a* (apply-type F2 A2) + [fixpoints** _] (check* fixpoints* e* a*)] + (return (&/T fixpoints** nil))) + state))) ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) ;; e* (apply-type F2 A1) @@ -614,13 +661,20 @@ ;; (return (&/T fixpoints** nil))) [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - (&/try-all% (&/|list (|do [F2 (deref ?id)] - (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) - e* (apply-type F1 A1) - a* (apply-type F1 A2) - [fixpoints** _] (check* fixpoints* e* a*)] - (return (&/T fixpoints** nil))))) + (fn [state] + (matchv ::M/objects [((|do [F2 (deref ?id)] + (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + e* (apply-type F1 A1) + a* (apply-type F1 A2) + [fixpoints** _] (check* fixpoints* e* a*)] + (return (&/T fixpoints** nil))) + state))) ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) ;; e* (apply-type F1 A1) -- cgit v1.2.3 From 1f0be2351bc76b0de15d97691f8ea0728d9ab321 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 22 May 2015 23:06:19 -0400 Subject: - Added a simple optimization based on the idea of avoiding to compare 2 type-functions which are most-likely the same, due to their name (remembering that when you define types using deftype, the type-function's name will correspond to the def's). - Gave empty environments to top-level type-functions, instead of leaving them with unset environments. --- source/lux.lux | 70 ++++++++++++++++++++++++++++---------------------------- src/lux/type.clj | 68 ++++++++++++++++++++++++++++-------------------------- 2 files changed, 70 insertions(+), 68 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index e3f3ba243..9b5601eb4 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -37,10 +37,10 @@ ## (| #Nil ## (#Cons (, a (List a))))) (_lux_def List - (#AllT [#None "List" "a" + (#AllT [(#Some #Nil) "lux;List" "a" (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) + (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) #Nil])]))] #Nil])]))])) (_lux_export List) @@ -49,7 +49,7 @@ ## (| #None ## (#Some a))) (_lux_def Maybe - (#AllT [#None "Maybe" "a" + (#AllT [(#Some #Nil) "lux;Maybe" "a" (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] (#Cons [["lux;Some" (#BoundT "a")] #Nil])]))])) @@ -70,7 +70,7 @@ Type (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) TypeEnv - (#AppT [(#AllT [#None "Type" "_" + (#AppT [(#AllT [(#Some #Nil) "Type" "_" (#VariantT (#Cons [["lux;DataT" Text] (#Cons [["lux;TupleT" (#AppT [List Type])] (#Cons [["lux;VariantT" TypeEnv] @@ -89,7 +89,7 @@ ## (& #counter Int ## #mappings (List (, k v)))) (_lux_def Bindings - (#AllT [#None "Bindings" "k" + (#AllT [(#Some #Nil) "lux;Bindings" "k" (#AllT [#None "" "v" (#RecordT (#Cons [["lux;counter" Int] (#Cons [["lux;mappings" (#AppT [List @@ -104,7 +104,7 @@ ## #locals (Bindings k v) ## #closure (Bindings k v))) (_lux_def Env - (#AllT [#None "Env" "k" + (#AllT [(#Some #Nil) "lux;Env" "k" (#AllT [#None "" "v" (#RecordT (#Cons [["lux;name" Text] (#Cons [["lux;inner-closures" Int] @@ -122,7 +122,7 @@ ## (deftype (Meta m v) ## (| (#Meta (, m v)))) (_lux_def Meta - (#AllT [#None "Meta" "m" + (#AllT [(#Some #Nil) "lux;Meta" "m" (#AllT [#None "" "v" (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") (#Cons [(#BoundT "v") @@ -143,12 +143,12 @@ ## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) (_lux_def Syntax' (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "Syntax'") + (#AppT [(#BoundT "lux;Syntax'") (#BoundT "w")])]) Syntax (_lux_case (#AppT [List Syntax]) SyntaxList - (#AllT [#None "Syntax'" "w" + (#AllT [(#Some #Nil) "lux;Syntax'" "w" (#VariantT (#Cons [["lux;BoolS" Bool] (#Cons [["lux;IntS" Int] (#Cons [["lux;RealS" Real] @@ -178,7 +178,7 @@ ## (| (#Left l) ## (#Right r))) (_lux_def Either - (#AllT [#None "_" "l" + (#AllT [(#Some #Nil) "lux;Either" "l" (#AllT [#None "" "r" (#VariantT (#Cons [["lux;Left" (#BoundT "l")] (#Cons [["lux;Right" (#BoundT "r")] @@ -188,7 +188,7 @@ ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) (_lux_def StateE - (#AllT [#None "StateE" "s" + (#AllT [(#Some #Nil) "lux;StateE" "s" (#AllT [#None "" "a" (#LambdaT [(#BoundT "s") (#AppT [(#AppT [Either Text]) @@ -218,7 +218,7 @@ ## (#MacroD m) ## (#AliasD Ident))) (_lux_def DefData' - (#AllT [#None "DefData'" "" + (#AllT [(#Some #Nil) "lux;DefData'" "" (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] (#Cons [["lux;ValueD" Type] (#Cons [["lux;MacroD" (#BoundT "")] @@ -234,20 +234,20 @@ #Nil])]))) (_lux_export LuxVar) -## (deftype #rec CompilerState +## (deftype #rec Compiler ## (& #source Reader -## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax))))))))) +## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))))) ## #module-aliases (List Void) ## #envs (List (Env Text (, LuxVar Type))) ## #types (Bindings Int Type) ## #host HostState)) -(_lux_def CompilerState - (#AppT [(#AllT [#None "CompilerState" "" +(_lux_def Compiler + (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [["lux;source" Reader] (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text (#Cons [(#AppT [List (#TupleT (#Cons [Text (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") + (#AppT [(#AppT [StateE (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) SyntaxList])])]) #Nil])])) @@ -261,13 +261,13 @@ (#Cons [["lux;seed" Int] #Nil])])])])])])]))]) Void])) -(_lux_export CompilerState) +(_lux_export Compiler) ## (deftype Macro -## (-> (List Syntax) (StateE CompilerState (List Syntax)))) +## (-> (List Syntax) (StateE Compiler (List Syntax)))) (_lux_def Macro (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE CompilerState]) + (#AppT [(#AppT [StateE Compiler]) SyntaxList])])) (_lux_export Macro) @@ -284,15 +284,15 @@ ## (def (return x) ## (All [a] -## (-> a CompilerState -## (Either Text (, CompilerState a)))) +## (-> a Compiler +## (Either Text (, Compiler a)))) ## ...) (_lux_def return - (_lux_: (#AllT [#None "" "a" + (_lux_: (#AllT [(#Some #Nil) "" "a" (#LambdaT [(#BoundT "a") - (#LambdaT [CompilerState + (#LambdaT [Compiler (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState + (#TupleT (#Cons [Compiler (#Cons [(#BoundT "a") #Nil])]))])])])]) (_lux_lambda _ val @@ -301,15 +301,15 @@ ## (def (fail msg) ## (All [a] -## (-> Text CompilerState -## (Either Text (, CompilerState a)))) +## (-> Text Compiler +## (Either Text (, Compiler a)))) ## ...) (_lux_def fail - (_lux_: (#AllT [#None "" "a" + (_lux_: (#AllT [(#Some #Nil) "" "a" (#LambdaT [Text - (#LambdaT [CompilerState + (#LambdaT [Compiler (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [CompilerState + (#TupleT (#Cons [Compiler (#Cons [(#BoundT "a") #Nil])]))])])])]) (_lux_lambda _ msg @@ -911,11 +911,11 @@ (fail "Wrong syntax for if"))) ## (deftype (Lux a) -## (-> CompilerState (Either Text (, CompilerState a)))) +## (-> Compiler (Either Text (, Compiler a)))) (def__ #export Lux Type (All' [a] - (->' CompilerState ($' Either Text (#TupleT (list CompilerState (B' a))))))) + (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) ## (defsig (Monad m) ## (: (All [a] (-> a (m a))) @@ -1246,7 +1246,7 @@ (replace-syntax replacements body) (reverse targs))] (return (_lux_: SyntaxList - (list (`' (#;AllT [#;None (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) + (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) #None (fail "'All' arguments must be symbols.")) @@ -1281,7 +1281,7 @@ (#Right [state module-name])))) (def__ (find-macro' modules current-module module name) - (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE CompilerState ($' List Syntax))))))))) + (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE Compiler ($' List Syntax))))))))) Text Text Text ($' Maybe Macro)) (do Maybe:Monad @@ -1949,7 +1949,7 @@ #seed seed} (case (get "lux" modules) (#Some lux) - (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax)))))) + (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] diff --git a/src/lux/type.clj b/src/lux/type.clj index 105528b8a..a2cf83624 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -16,14 +16,14 @@ (def $Void (&/V "lux;VariantT" (&/|list))) (def List - (&/V "lux;AllT" (&/T (&/V "lux;None" nil) "List" "a" + (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;List" "a" (&/V "lux;VariantT" (&/|list (&/T "lux;Nil" Unit) (&/T "lux;Cons" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "List") + (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;List") (&/V "lux;BoundT" "a"))))))))))) (def Maybe - (&/V "lux;AllT" (&/T (&/V "lux;None" nil) "Maybe" "a" + (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;Maybe" "a" (&/V "lux;VariantT" (&/|list (&/T "lux;None" Unit) (&/T "lux;Some" (&/V "lux;BoundT" "a"))))))) @@ -31,7 +31,7 @@ (let [Type (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Type") (&/V "lux;BoundT" "_"))) TypeEnv (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Type)))) TypePair (&/V "lux;TupleT" (&/|list Type Type))] - (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V "lux;None" nil) "Type" "_" + (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "Type" "_" (&/V "lux;VariantT" (&/|list (&/T "lux;DataT" Text) (&/T "lux;TupleT" (&/V "lux;AppT" (&/T List Type))) (&/T "lux;VariantT" TypeEnv) @@ -49,7 +49,7 @@ (&/V "lux;AllT" (&/T (&/V "lux;None" nil) name arg body))) (def Bindings - (fAll "Bindings" "k" + (fAll "lux;Bindings" "k" (fAll "" "v" (&/V "lux;RecordT" (&/|list (&/T "lux;counter" Int) (&/T "lux;mappings" (&/V "lux;AppT" (&/T List @@ -59,7 +59,7 @@ (def Env (let [bindings (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings (&/V "lux;BoundT" "k"))) (&/V "lux;BoundT" "v")))] - (fAll "Env" "k" + (fAll "lux;Env" "k" (fAll "" "v" (&/V "lux;RecordT" (&/|list (&/T "lux;name" Text) @@ -72,7 +72,7 @@ (&/V "lux;TupleT" (&/|list Text Int Int))) (def Meta - (fAll "Meta" "m" + (fAll "lux;Meta" "m" (fAll "" "v" (&/V "lux;VariantT" (&/|list (&/T "lux;Meta" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m") (&/V "lux;BoundT" "v"))))))))) @@ -81,10 +81,10 @@ (def Syntax* (let [Syntax* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Syntax'") + (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Syntax'") (&/V "lux;BoundT" "w"))))) Syntax*List (&/V "lux;AppT" (&/T List Syntax*))] - (fAll "Syntax'" "w" + (fAll "lux;Syntax'" "w" (&/V "lux;VariantT" (&/|list (&/T "lux;BoolS" Bool) (&/T "lux;IntS" Int) (&/T "lux;RealS" Real) @@ -104,13 +104,13 @@ (def ^:private SyntaxList (&/V "lux;AppT" (&/T List Syntax))) (def Either - (fAll "_" "l" + (fAll "lux;Either" "l" (fAll "" "r" (&/V "lux;VariantT" (&/|list (&/T "lux;Left" (&/V "lux;BoundT" "l")) (&/T "lux;Right" (&/V "lux;BoundT" "r"))))))) (def StateE - (fAll "StateE" "s" + (fAll "lux;StateE" "s" (fAll "" "a" (&/V "lux;LambdaT" (&/T (&/V "lux;BoundT" "s") (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Either Text)) @@ -129,7 +129,7 @@ ))) (def DefData* - (fAll "DefData'" "" + (fAll "lux;DefData'" "" (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Unit) (&/T "lux;ValueD" Type) (&/T "lux;MacroD" (&/V "lux;BoundT" "")) @@ -139,8 +139,8 @@ (&/V "lux;VariantT" (&/|list (&/T "lux;Local" Int) (&/T "lux;Global" Ident)))) -(def CompilerState - (&/V "lux;AppT" (&/T (fAll "CompilerState" "" +(def $Compiler + (&/V "lux;AppT" (&/T (fAll "lux;Compiler" "" (&/V "lux;RecordT" (&/|list (&/T "lux;source" Reader) (&/T "lux;modules" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" @@ -150,7 +150,7 @@ (&/V "lux;TupleT" (&/|list Bool (&/V "lux;AppT" (&/T DefData* (&/V "lux;LambdaT" (&/T SyntaxList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "CompilerState") + (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Compiler") (&/V "lux;BoundT" ""))))) SyntaxList))))))))))))))))) (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List $Void))) @@ -164,7 +164,7 @@ (def Macro (&/V "lux;LambdaT" (&/T SyntaxList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE CompilerState)) + (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE $Compiler)) SyntaxList))))) (defn bound? [id] @@ -433,23 +433,25 @@ (and (type= xlambda ylambda) (type= xparam yparam)) [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] - (and (= xname yname) - (= xarg yarg) - ;; (matchv ::M/objects [xenv yenv] - ;; [["lux;None" _] ["lux;None" _]] - ;; true - - ;; [["lux;Some" xenv*] ["lux;Some" yenv*]] - ;; (&/fold (fn [old bname] - ;; (and old - ;; (type= (&/|get bname xenv*) (&/|get bname yenv*)))) - ;; (= (&/|length xenv*) (&/|length yenv*)) - ;; (&/|keys xenv*)) - - ;; [_ _] - ;; false) - (type= xbody ybody) - ) + (or (and (not= "" xname) + (= xname yname)) + (and (= xname yname) + (= xarg yarg) + ;; (matchv ::M/objects [xenv yenv] + ;; [["lux;None" _] ["lux;None" _]] + ;; true + + ;; [["lux;Some" xenv*] ["lux;Some" yenv*]] + ;; (&/fold (fn [old bname] + ;; (and old + ;; (type= (&/|get bname xenv*) (&/|get bname yenv*)))) + ;; (= (&/|length xenv*) (&/|length yenv*)) + ;; (&/|keys xenv*)) + + ;; [_ _] + ;; false) + (type= xbody ybody) + )) [_ _] false -- cgit v1.2.3 From e86b31726a19b0706f3618467775ba8ce6030393 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 24 May 2015 18:55:08 -0400 Subject: - Cleaned-up a few things in lux.lux - Replace most instances of "=" with ".equals". - Added an optimization to lux.type/type= that drastically speeds-up type comparisons. --- source/lux.lux | 210 ++++++++-------- src/lux/analyser.clj | 2 +- src/lux/analyser/base.clj | 2 +- src/lux/analyser/case.clj | 10 +- src/lux/analyser/lux.clj | 8 +- src/lux/analyser/module.clj | 2 +- src/lux/base.clj | 14 +- src/lux/compiler.clj | 2 +- src/lux/host.clj | 12 +- src/lux/lexer.clj | 19 +- src/lux/type.clj | 591 ++++++++++++++++++++++---------------------- 11 files changed, 432 insertions(+), 440 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 9b5601eb4..ac47e81eb 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -360,7 +360,7 @@ (fail "Wrong syntax for let'"))))) (_lux_declare-macro let') -(_lux_def lambda_ +(_lux_def lambda' (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens @@ -374,7 +374,7 @@ body _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) (#Cons [(_meta (#TupleS args')) (#Cons [body #Nil])])])))) #Nil])])])]))) @@ -390,7 +390,7 @@ body _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) (#Cons [(_meta (#TupleS args')) (#Cons [body #Nil])])])))) #Nil])])])]))) @@ -398,11 +398,11 @@ _ (fail "Wrong syntax for lambda"))))) -(_lux_declare-macro lambda_) +(_lux_declare-macro lambda') -(_lux_def def_ +(_lux_def def' (_lux_: Macro - (lambda_ [tokens] + (lambda' [tokens] (_lux_case tokens (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) @@ -412,7 +412,7 @@ (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) (#Cons [name (#Cons [(_meta (#TupleS args)) (#Cons [body #Nil])])])]))) @@ -440,7 +440,7 @@ (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda_"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) (#Cons [name (#Cons [(_meta (#TupleS args)) (#Cons [body #Nil])])])]))) @@ -462,14 +462,14 @@ _ (fail "Wrong syntax for def") )))) -(_lux_declare-macro def_) +(_lux_declare-macro def') -(def_ #export (defmacro tokens) +(def' #export (defmacro tokens) Macro (_lux_case tokens (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($form (#Cons [($symbol ["lux" "def'"]) (#Cons [($form (#Cons [name args])) (#Cons [($symbol ["lux" "Macro"]) (#Cons [body @@ -480,7 +480,7 @@ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def_"]) + (#Cons [($form (#Cons [($symbol ["lux" "def'"]) (#Cons [($tag ["" "export"]) (#Cons [($form (#Cons [name args])) (#Cons [($symbol ["lux" "Macro"]) @@ -575,7 +575,7 @@ _ (fail "Wrong syntax for $'"))) -(def_ #export (fold f init xs) +(def' #export (fold f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) @@ -588,19 +588,19 @@ (#Cons [x xs']) (fold f (f init x) xs'))) -(def_ #export (reverse list) +(def' #export (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) (fold (_lux_: (All' [a] (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda_ [tail head] + (lambda' [tail head] (#Cons [head tail]))) #Nil list)) (defmacro #export (list xs) (return (_lux_: SyntaxList - (#Cons [(fold (lambda_ [tail head] + (#Cons [(fold (lambda' [tail head] (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) #Nil])])))) @@ -612,7 +612,7 @@ (_lux_case (reverse xs) (#Cons [last init]) (return (_lux_: SyntaxList - (list (fold (lambda_ [tail head] + (list (fold (lambda' [tail head] (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) (_meta (#TupleS (list head tail))))))) last @@ -640,7 +640,7 @@ (list ($form (list ($symbol ["" "_lux_lambda"]) ($symbol name) harg - (fold (lambda_ [body' arg] + (fold (lambda' [body' arg] ($form (list ($symbol ["" "_lux_lambda"]) ($symbol ["" ""]) arg @@ -651,7 +651,7 @@ _ (fail "Wrong syntax for lambda")))) -(defmacro (def__ tokens) +(defmacro (def'' tokens) (_lux_case tokens (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) @@ -698,7 +698,7 @@ (fail "Wrong syntax for def") )) -(def__ (as-pairs xs) +(def'' (as-pairs xs) (All' [a] (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) (_lux_case xs @@ -728,7 +728,7 @@ _ (fail "Wrong syntax for let"))) -(def__ #export (map f xs) +(def'' #export (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs @@ -738,7 +738,7 @@ (#Cons [x xs']) (#Cons [(f x) (map f xs')]))) -(def__ #export (any? p xs) +(def'' #export (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) (_lux_case xs @@ -750,7 +750,7 @@ true true false (any? p xs')))) -(def__ (spliced? token) +(def'' (spliced? token) (->' Syntax Bool) (_lux_case token (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) @@ -759,13 +759,13 @@ _ false)) -(def__ (wrap-meta content) +(def'' (wrap-meta content) (->' Syntax Syntax) (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) content))))))) -(def__ (untemplate-list tokens) +(def'' (untemplate-list tokens) (->' ($' List Syntax) Syntax) (_lux_case tokens #Nil @@ -775,7 +775,7 @@ (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) (_meta (#TupleS (list token (untemplate-list tokens'))))))))) -(def__ (list:++ xs ys) +(def'' (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) (_lux_case xs (#Cons [x xs']) @@ -795,7 +795,7 @@ _ (fail "Wrong syntax for $"))) -(def__ (splice untemplate tag elems) +(def'' (splice untemplate tag elems) (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) (_lux_case (any? spliced? elems) true @@ -818,7 +818,7 @@ false (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) -(def__ (untemplate subst token) +(def'' (untemplate subst token) (->' Text Syntax Syntax) (_lux_case token (#Meta [_ (#BoolS value)]) @@ -912,7 +912,7 @@ ## (deftype (Lux a) ## (-> Compiler (Either Text (, Compiler a)))) -(def__ #export Lux +(def'' #export Lux Type (All' [a] (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) @@ -922,7 +922,7 @@ ## return) ## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) ## bind)) -(def__ Monad +(def'' Monad Type (All' [m] (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] @@ -930,7 +930,7 @@ ($' (B' m) (B' a)) ($' (B' m) (B' b))))])))) -(def__ Maybe:Monad +(def'' Maybe:Monad ($' Monad Maybe) {#lux;return (lambda return [x] @@ -942,7 +942,7 @@ #None #None (#Some a) (f a)))}) -(def__ Lux:Monad +(def'' Lux:Monad ($' Monad Lux) {#lux;return (lambda [x] @@ -1009,7 +1009,7 @@ _ (fail "Wrong syntax for do"))) -(def__ (map% m f xs) +(def'' (map% m f xs) ## (All [m a b] ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) (All' [m a b] @@ -1029,13 +1029,13 @@ (;return (_lux_: List (#Cons [y ys])))) ))) -(def__ #export (. f g) +(def'' #export (. f g) (All' [a b c] (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) (lambda [x] (f (g x)))) -(def__ (get-ident x) +(def'' (get-ident x) (-> Syntax ($' Maybe Text)) (_lux_case x (#Meta [_ (#SymbolS ["" sname])]) @@ -1044,7 +1044,7 @@ _ #None)) -(def__ (tuple->list tuple) +(def'' (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) (_lux_case tuple (#Meta [_ (#TupleS members)]) @@ -1053,11 +1053,11 @@ _ #None)) -(def__ RepEnv +(def'' RepEnv Type ($' List (, Text Syntax))) -(def__ (make-env xs ys) +(def'' (make-env xs ys) (-> ($' List Text) ($' List Syntax) RepEnv) (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) [xs ys]) @@ -1067,12 +1067,12 @@ _ #Nil)) -(def__ (text:= x y) +(def'' (text:= x y) (-> Text Text Bool) (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] x [y])) -(def__ (get-rep key env) +(def'' (get-rep key env) (-> Text RepEnv ($' Maybe Syntax)) (_lux_case env #Nil @@ -1083,7 +1083,7 @@ (#Some v) (get-rep key env')))) -(def__ (apply-template env template) +(def'' (apply-template env template) (-> RepEnv Syntax Syntax) (_lux_case template (#Meta [_ (#SymbolS ["" sname])]) @@ -1110,7 +1110,7 @@ _ template)) -(def__ (join-map f xs) +(def'' (join-map f xs) (All' [a b] (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs @@ -1140,7 +1140,7 @@ (fail "Wrong syntax for do-template"))) (do-template [ ] - [(def__ #export ( x y) + [(def'' #export ( x y) (-> Bool) ( x y))] @@ -1153,7 +1153,7 @@ ) (do-template [ ] - [(def__ #export ( x y) + [(def'' #export ( x y) (-> ) ( x y))] @@ -1169,29 +1169,29 @@ [real:% _jvm_drem Real] ) -(def__ (multiple? div n) +(def'' (multiple? div n) (-> Int Int Bool) (int:= 0 (int:% n div))) -(def__ #export (length list) +(def'' #export (length list) (-> List Int) (fold (lambda [acc _] (int:+ 1 acc)) 0 list)) -(def__ #export (not x) +(def'' #export (not x) (-> Bool Bool) (if x false true)) -(def__ #export (text:++ x y) +(def'' #export (text:++ x y) (-> Text Text Text) (_jvm_invokevirtual java.lang.String concat [java.lang.String] x [y])) -(def__ (ident->text ident) +(def'' (ident->text ident) (-> Ident Text) (let [[module name] ident] ($ text:++ module ";" name))) -(def__ (replace-syntax reps syntax) +(def'' (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) (_lux_case syntax (#Meta [_ (#SymbolS ["" name])]) @@ -1255,7 +1255,7 @@ (fail "Wrong syntax for All")) )) -(def__ (get k plist) +(def'' (get k plist) (All [a] (-> Text ($' List (, Text a)) ($' Maybe a))) (_lux_case plist @@ -1267,7 +1267,7 @@ #Nil #None)) -(def__ #export (get-module-name state) +(def'' #export (get-module-name state) ($' Lux Text) (_lux_case state {#source source #modules modules #module-aliases module-aliases @@ -1280,7 +1280,7 @@ (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) (#Right [state module-name])))) -(def__ (find-macro' modules current-module module name) +(def'' (find-macro' modules current-module module name) (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE Compiler ($' List Syntax))))))))) Text Text Text ($' Maybe Macro)) @@ -1301,7 +1301,7 @@ _ #None))) -(def__ #export (find-macro ident) +(def'' #export (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) (do Lux:Monad [current-module get-module-name] @@ -1313,12 +1313,12 @@ #seed seed} (#Right [state (find-macro' modules current-module module name)])))))) -(def__ (list:join xs) +(def'' (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) (fold list:++ #Nil xs)) -## (def__ #export (normalize ident) +## (def'' #export (normalize ident) ## (-> Ident ($' Lux Ident)) ## (_lux_case ident ## ["" name] @@ -1328,7 +1328,7 @@ ## _ ## (return ident))) -(def__ #export (normalize ident state) +(def'' #export (normalize ident state) (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] @@ -1387,11 +1387,11 @@ (;return (_lux_: SyntaxList (list (`' (#;RecordT (;list (~@ pairs)))))))))) -(def__ #export (->text x) +(def'' #export (->text x) (-> (^ java.lang.Object) Text) (_jvm_invokevirtual java.lang.Object toString [] x [])) -(def__ #export (interpose sep xs) +(def'' #export (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) (_lux_case xs @@ -1404,7 +1404,7 @@ (#Cons [x xs']) (list& x sep (interpose sep xs')))) -(def__ #export (syntax:show syntax) +(def'' #export (syntax:show syntax) (-> Syntax Text) (_lux_case syntax (#Meta [_ (#BoolS value)]) @@ -1446,7 +1446,7 @@ "}") )) -(def__ #export (macro-expand syntax) +(def'' #export (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) @@ -1479,7 +1479,7 @@ _ (return (_lux_: SyntaxList (list syntax))))) -(def__ (walk-type type) +(def'' (walk-type type) (-> Syntax Syntax) (_lux_case type (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) @@ -1525,8 +1525,8 @@ (defmacro #export (:! tokens) (_lux_case tokens (#Cons [type (#Cons [value #Nil])]) - (return (_lux_: SyntaxList - (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) + (return (: (List Syntax) + (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) _ (fail "Wrong syntax for :!"))) @@ -1562,9 +1562,9 @@ _ (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (_lux_: SyntaxList - (list& (`' (_lux_def (~ name) (;type` (~ type')))) - with-export)))) + (return (: (List Syntax) + (list& (`' (_lux_def (~ name) (;type` (~ type')))) + with-export)))) #None (fail "Wrong syntax for deftype")) @@ -1636,11 +1636,11 @@ #None body'))] - (return (_lux_: SyntaxList - (list& (`' (_lux_def (~ name) (~ body''))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) + (return (: (List Syntax) + (list& (`' (_lux_def (~ name) (~ body''))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for def")))) @@ -1702,10 +1702,10 @@ _ (do Lux:Monad [patterns' (map% Lux:Monad macro-expand patterns)] - (;return (_lux_: SyntaxList - (list:join (map (: (-> Syntax (List Syntax)) - (lambda [pattern] (list pattern body))) - (list:join patterns'))))))) + (;return (: (List Syntax) + (list:join (map (: (-> Syntax (List Syntax)) + (lambda [pattern] (list pattern body))) + (list:join patterns'))))))) _ (fail "Wrong syntax for \\or"))) @@ -1804,11 +1804,11 @@ _ (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (_lux_: SyntaxList - (list& (`' (_lux_def (~ name) (~ sigs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) + (return (: (List Syntax) + (list& (`' (_lux_def (~ name) (~ sigs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for defsig")))) @@ -1828,8 +1828,8 @@ _ (fail "Structures require defined members!")))) tokens')] - (;return (_lux_: SyntaxList - (list ($record members)))))) + (;return (: (List Syntax) + (list ($record members)))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1858,11 +1858,11 @@ _ (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (_lux_: SyntaxList - (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) + (return (: (List Syntax) + (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) #None (fail "Wrong syntax for defsig")))) @@ -1957,11 +1957,11 @@ (list name) (list))))) lux)] - (#Right [state (_lux_: SyntaxList - (map (: (-> Text Syntax) - (lambda [name] - (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) - (list:join to-alias)))])) + (#Right [state (: (List Syntax) + (map (: (-> Text Syntax) + (lambda [name] + (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) + (list:join to-alias)))])) #None (#Left "Uh, oh... The universe is not working properly...")) @@ -2065,33 +2065,23 @@ [($tag [module name]) ($symbol ["" name])]))) slots)) _ (println (text:++ "Using pattern: " (syntax:show pattern)))] - (#Right [state (_lux_: SyntaxList - (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) + (#Right [state (: (List Syntax) + (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) _ (#Left "Can only \"use\" records.")))))) _ (let [dummy ($symbol ["" ""])] - (#Right [state (_lux_: SyntaxList - (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) (~ body))))))]))) + (#Right [state (: (List Syntax) + (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) + (~ body))))))]))) _ (#Left "Wrong syntax for defsig"))) -(defmacro #export (when tokens) - (case tokens - (\ (list test body)) - (return (_lux_: SyntaxList - (list (` (if (~ test) - (#Some (~ body)) - #None))))) - - _ - (fail "Wrong syntax for when"))) - (def #export (flip f) (All [a b c] (-> (-> a b c) (-> b a c))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 3c5c5c956..ba0fe4e66 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -514,7 +514,7 @@ (defn ^:private analyse-ast [eval! exo-type token] (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] - (do (assert (= 1 (&/|length ?values)) "[Analyser Error] Can only tag 1 value.") + (do (assert (.equals ^Object (&/|length ?values) 1) "[Analyser Error] Can only tag 1 value.") (&&lux/analyse-variant (partial analyse-ast eval!) exo-type ?ident (&/|head ?values))) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index a4c96c350..11e92f7b7 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -21,7 +21,7 @@ (defn resolved-ident [ident] (|let [[?module ?name] ident] - (|do [module* (if (= "" ?module) + (|do [module* (if (.equals "" ?module) &/get-module-name (return ?module))] (return (&/ident->text (&/T module* ?name)))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index f27a541ee..43e5ee5e7 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -56,7 +56,7 @@ [["lux;TupleS" ?members]] (matchv ::M/objects [value-type] [["lux;TupleT" ?member-types]] - (if (not (= (&/|length ?member-types) (&/|length ?members))) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) (fail (str "[Analyser error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) (|do [[=tests =kont] (&/fold (fn [kont* vm] (|let [[v m] vm] @@ -74,7 +74,7 @@ (|do [value-type* (resolve-type value-type)] (matchv ::M/objects [value-type*] [["lux;RecordT" ?slot-types]] - (if (not (= (&/|length ?slot-types) (&/|length ?slots))) + (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) (fail (str "[Analyser error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) (|do [[=tests =kont] (&/fold (fn [kont* slot] (|let [[sn sv] slot] @@ -168,7 +168,7 @@ (return (&/V "TupleTotal" (&/T total? structs)))) [["TupleTotal" [total? ?values]] ["TupleTestAC" ?tests]] - (if (= (&/|length ?values) (&/|length ?tests)) + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [v t] (merge-total v (&/T t ?body))) ?values ?tests)] @@ -187,11 +187,11 @@ (return (&/V "RecordTotal" (&/T total? structs)))) [["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]] - (if (= (&/|length ?values) (&/|length ?tests)) + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [left right] (|let [[lslot sub-struct] left [rslot value]right] - (if (= lslot rslot) + (if (.equals ^Object lslot rslot) (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] (return (&/T lslot sub-struct*))) (fail "[Pattern-matching error] Record slots mismatch.")))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 7600f34ff..dff936fbe 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -110,7 +110,7 @@ [inner outer] (&/|split-with no-binding? stack)] (matchv ::M/objects [outer] [["lux;Nil" _]] - ((|do [[[r-module r-name] $def] (&&module/find-def (if (= "" ?module) module-name ?module) + ((|do [[[r-module r-name] $def] (&&module/find-def (if (.equals "" ?module) module-name ?module) ?name) endo-type (matchv ::M/objects [$def] [["lux;ValueD" ?type]] @@ -121,7 +121,8 @@ [["lux;TypeD" _]] (return &type/Type)) - _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) @@ -142,7 +143,8 @@ [["lux;TypeD" _]] (return &type/Type)) - _ (if (and (= &type/Type endo-type) (= &type/Type exo-type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index f36dc044a..f882f1275 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -68,7 +68,7 @@ (if-let [$def (&/|get name $module)] (matchv ::M/objects [$def] [[exported? $$def]] - (if (or exported? (= current-module module)) + (if (or exported? (.equals ^Object current-module module)) (matchv ::M/objects [$$def] [["lux;AliasD" [?r-module ?r-name]]] ((find-def ?r-module ?r-name) diff --git a/src/lux/base.clj b/src/lux/base.clj index edf6781ea..7f551cdb0 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -85,7 +85,7 @@ nil [["lux;Cons" [[k v] table*]]] - (if (= k slot) + (if (.equals ^Object k slot) v (|get slot table*)))) @@ -95,7 +95,7 @@ (V "lux;Cons" (T (T slot value) (V "lux;Nil" nil))) [["lux;Cons" [[k v] table*]]] - (if (= k slot) + (if (.equals ^Object k slot) (V "lux;Cons" (T (T slot value) table*)) (V "lux;Cons" (T (T k v) (|put slot value table*)))))) @@ -105,7 +105,7 @@ table [["lux;Cons" [[k v] table*]]] - (if (= k slot) + (if (.equals ^Object k slot) table* (V "lux;Cons" (T (T k v) (|remove slot table*)))))) @@ -115,7 +115,7 @@ table [["lux;Cons" [[k* v] table*]]] - (if (= k k*) + (if (.equals ^Object k k*) (V "lux;Cons" (T (T k* (f v)) table*)) (V "lux;Cons" (T (T k* v) (|update k f table*)))))) @@ -233,7 +233,7 @@ false [["lux;Cons" [[k* _] table*]]] - (or (= k k*) + (or (.equals ^Object k k*) (|contains? k table*)))) (defn fold [f init xs] @@ -384,7 +384,7 @@ ((exhaust% step) state*) [["lux;Left" msg]] - (if (= "[Reader Error] EOF" msg) + (if (.equals "[Reader Error] EOF" msg) (return* state nil) (fail* msg))))) @@ -570,7 +570,7 @@ (str "#" ?module ";" ?tag) [["lux;Meta" [_ ["lux;SymbolS" [?module ?ident]]]]] - (if (= "" ?module) + (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 6fb9e2c6d..e491fbdfe 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -346,7 +346,7 @@ (defn ^:private compile-module [name] (fn [state] (if (->> state (&/get$ &/$MODULES) (&/|contains? name)) - (if (= name "lux") + (if (.equals ^Object name "lux") (return* state nil) (fail* "[Compiler Error] Can't redefine a module!")) (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) diff --git a/src/lux/host.clj b/src/lux/host.clj index 77687dbef..8817ea338 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -18,7 +18,7 @@ (str (.getName pkg) ".") "") (.getSimpleName class)))] - (if (= "void" base) + (if (.equals "void" base) (return &type/$Void) (return (&/V "lux;DataT" (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) base))) @@ -78,8 +78,8 @@ (do-template [ ] (defn [target field] (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName target)) - :when (and (= field (.getName =field)) - (= (Modifier/isStatic (.getModifiers =field))))] + :when (and (.equals ^Object field (.getName =field)) + (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] (.getType =field)))] (|do [=type (class->type type*)] (return =type)) @@ -92,9 +92,9 @@ (do-template [ ] (defn [target method-name args] (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName target)) - :when (and (= method-name (.getName =method)) - (= (Modifier/isStatic (.getModifiers =method))) - (&/fold2 #(and %1 (= %2 %3)) + :when (and (.equals ^Object method-name (.getName =method)) + (.equals ^Object (Modifier/isStatic (.getModifiers =method))) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) true args (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))] diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index d2ab4a5d7..a137ca863 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -6,16 +6,15 @@ ;; [Utils] (defn ^:private escape-char [escaped] - (condp = escaped - "\\t" (return "\t") - "\\b" (return "\b") - "\\n" (return "\n") - "\\r" (return "\r") - "\\f" (return "\f") - "\\\"" (return "\"") - "\\\\" (return "\\") - ;; else - (fail (str "[Lexer Error] Unknown escape character: " escaped)))) + (cond (.equals ^Object escaped "\\t") (return "\t") + (.equals ^Object escaped "\\b") (return "\b") + (.equals ^Object escaped "\\n") (return "\n") + (.equals ^Object escaped "\\r") (return "\r") + (.equals ^Object escaped "\\f") (return "\f") + (.equals ^Object escaped "\\\"") (return "\"") + (.equals ^Object escaped "\\\\") (return "\\") + :else + (fail (str "[Lexer Error] Unknown escape character: " escaped)))) (defn ^:private lex-text-body [_] (&/try-all% (&/|list (|do [[_ [prefix escaped]] (&reader/read-regex2 #"(?s)^([^\"\\]*)(\\.)") diff --git a/src/lux/type.clj b/src/lux/type.clj index a2cf83624..25e3e1053 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -228,7 +228,7 @@ (fn [state] ((|do [mappings* (&/map% (fn [binding] (|let [[?id ?type] binding] - (if (= id ?id) + (if (.equals ^Object id ?id) (return binding) (matchv ::M/objects [?type] [["lux;None" _]] @@ -237,7 +237,7 @@ [["lux;Some" ?type*]] (matchv ::M/objects [?type*] [["lux;VarT" ?id*]] - (if (= id ?id*) + (if (.equals ^Object id ?id*) (return (&/T ?id (&/V "lux;None" nil))) (return binding)) @@ -269,7 +269,7 @@ (defn ^:private clean* [?tid type] (matchv ::M/objects [type] [["lux;VarT" ?id]] - (if (= ?tid ?id) + (if (.equals ^Object ?tid ?id) (deref ?id) (return type)) @@ -390,53 +390,52 @@ )) (defn type= [x y] - (let [output (matchv ::M/objects [x y] - [["lux;DataT" xname] ["lux;DataT" yname]] - (= xname yname) - - [["lux;TupleT" xelems] ["lux;TupleT" yelems]] - (&/fold2 (fn [old x y] - (and old (type= x y))) - true - xelems yelems) - - [["lux;VariantT" xcases] ["lux;VariantT" ycases]] - (&/fold2 (fn [old xcase ycase] - (|let [[xname xtype] xcase - [yname ytype] ycase] - (and old (= xname yname) (type= xtype ytype)))) - true - xcases ycases) - - [["lux;RecordT" xslots] ["lux;RecordT" yslots]] - (&/fold2 (fn [old xslot yslot] - (|let [[xname xtype] xslot - [yname ytype] yslot] - (and old (= xname yname) (type= xtype ytype)))) - true - xslots yslots) - - [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] - (and (type= xinput yinput) - (type= xoutput youtput)) - - [["lux;VarT" xid] ["lux;VarT" yid]] - (= xid yid) - - [["lux;BoundT" xname] ["lux;BoundT" yname]] - (= xname yname) - - [["lux;ExT" xid] ["lux;ExT" yid]] - (= xid yid) - - [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]] - (and (type= xlambda ylambda) (type= xparam yparam)) - - [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] - (or (and (not= "" xname) - (= xname yname)) - (and (= xname yname) - (= xarg yarg) + (or (clojure.lang.Util/identical x y) + (let [output (matchv ::M/objects [x y] + [["lux;DataT" xname] ["lux;DataT" yname]] + (.equals ^Object xname yname) + + [["lux;TupleT" xelems] ["lux;TupleT" yelems]] + (&/fold2 (fn [old x y] + (and old (type= x y))) + true + xelems yelems) + + [["lux;VariantT" xcases] ["lux;VariantT" ycases]] + (&/fold2 (fn [old xcase ycase] + (|let [[xname xtype] xcase + [yname ytype] ycase] + (and old (.equals ^Object xname yname) (type= xtype ytype)))) + true + xcases ycases) + + [["lux;RecordT" xslots] ["lux;RecordT" yslots]] + (&/fold2 (fn [old xslot yslot] + (|let [[xname xtype] xslot + [yname ytype] yslot] + (and old (.equals ^Object xname yname) (type= xtype ytype)))) + true + xslots yslots) + + [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] + (and (type= xinput yinput) + (type= xoutput youtput)) + + [["lux;VarT" xid] ["lux;VarT" yid]] + (.equals ^Object xid yid) + + [["lux;BoundT" xname] ["lux;BoundT" yname]] + (.equals ^Object xname yname) + + [["lux;ExT" xid] ["lux;ExT" yid]] + (.equals ^Object xid yid) + + [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]] + (and (type= xlambda ylambda) (type= xparam yparam)) + + [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] + (and (.equals ^Object xname yname) + (.equals ^Object xarg yarg) ;; (matchv ::M/objects [xenv yenv] ;; [["lux;None" _] ["lux;None" _]] ;; true @@ -451,12 +450,12 @@ ;; [_ _] ;; false) (type= xbody ybody) - )) + ) - [_ _] - false - )] - output)) + [_ _] + false + )] + output))) (defn ^:private fp-get [k fixpoints] (|let [[e a] k] @@ -553,272 +552,274 @@ (defn ^:private check* [fixpoints expected actual] ;; (swap! counter update-in [[(aget expected 0) (aget actual 0)]] ;; #(inc (or % 0))) - (matchv ::M/objects [expected actual] - [["lux;VarT" ?eid] ["lux;VarT" ?aid]] - (if (= ?eid ?aid) - (return (&/T fixpoints nil)) - (|do [ebound (fn [state] - (matchv ::M/objects [((deref ?eid) state)] - [["lux;Right" [state* ebound]]] - (return* state* (&/V "lux;Some" ebound)) - - [["lux;Left" _]] - (return* state (&/V "lux;None" nil)))) - abound (fn [state] - (matchv ::M/objects [((deref ?aid) state)] - [["lux;Right" [state* abound]]] - (return* state* (&/V "lux;Some" abound)) - - [["lux;Left" _]] - (return* state (&/V "lux;None" nil))))] - (matchv ::M/objects [ebound abound] - [["lux;None" _] ["lux;None" _]] - (|do [_ (set-var ?eid actual)] - (return (&/T fixpoints nil))) - - [["lux;Some" etype] ["lux;None" _]] - (check* fixpoints etype actual) - - [["lux;None" _] ["lux;Some" atype]] - (check* fixpoints expected atype) - - [["lux;Some" etype] ["lux;Some" atype]] - (check* fixpoints etype atype)))) - - [["lux;VarT" ?id] _] - (fn [state] - (matchv ::M/objects [((set-var ?id actual) state)] - [["lux;Right" [state* _]]] - (return* state* (&/T fixpoints nil)) - - [["lux;Left" _]] - ((|do [bound (deref ?id)] - (check* fixpoints bound actual)) - state))) - - [_ ["lux;VarT" ?id]] - (fn [state] - (matchv ::M/objects [((set-var ?id expected) state)] - [["lux;Right" [state* _]]] - (return* state* (&/T fixpoints nil)) + (if (clojure.lang.Util/identical expected actual) + (return (&/T fixpoints nil)) + (matchv ::M/objects [expected actual] + [["lux;VarT" ?eid] ["lux;VarT" ?aid]] + (if (.equals ^Object ?eid ?aid) + (return (&/T fixpoints nil)) + (|do [ebound (fn [state] + (matchv ::M/objects [((deref ?eid) state)] + [["lux;Right" [state* ebound]]] + (return* state* (&/V "lux;Some" ebound)) + + [["lux;Left" _]] + (return* state (&/V "lux;None" nil)))) + abound (fn [state] + (matchv ::M/objects [((deref ?aid) state)] + [["lux;Right" [state* abound]]] + (return* state* (&/V "lux;Some" abound)) + + [["lux;Left" _]] + (return* state (&/V "lux;None" nil))))] + (matchv ::M/objects [ebound abound] + [["lux;None" _] ["lux;None" _]] + (|do [_ (set-var ?eid actual)] + (return (&/T fixpoints nil))) + + [["lux;Some" etype] ["lux;None" _]] + (check* fixpoints etype actual) + + [["lux;None" _] ["lux;Some" atype]] + (check* fixpoints expected atype) + + [["lux;Some" etype] ["lux;Some" atype]] + (check* fixpoints etype atype)))) + + [["lux;VarT" ?id] _] + (fn [state] + (matchv ::M/objects [((set-var ?id actual) state)] + [["lux;Right" [state* _]]] + (return* state* (&/T fixpoints nil)) - [["lux;Left" _]] - ((|do [bound (deref ?id)] - (check* fixpoints expected bound)) - state))) + [["lux;Left" _]] + ((|do [bound (deref ?id)] + (check* fixpoints bound actual)) + state))) + + [_ ["lux;VarT" ?id]] + (fn [state] + (matchv ::M/objects [((set-var ?id expected) state)] + [["lux;Right" [state* _]]] + (return* state* (&/T fixpoints nil)) - [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] - (fn [state] - (matchv ::M/objects [((|do [F1 (deref ?eid)] - (fn [state] - (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - ((check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) - state)))) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + [["lux;Left" _]] + ((|do [bound (deref ?id)] + (check* fixpoints expected bound)) + state))) + + [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] + (fn [state] + (matchv ::M/objects [((|do [F1 (deref ?eid)] + (fn [state] + (matchv ::M/objects [((|do [F2 (deref ?aid)] + (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + ((check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + state)))) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" _]] - ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - [fixpoints** _] (check* fixpoints* A1 A2)] - (return (&/T fixpoints** nil))) - state)))) - ;; (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - ;; _ (check* fixpoints A1 A2)] - ;; (return (&/T fixpoints nil))) - - [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - (fn [state] - (matchv ::M/objects [((|do [F1 (deref ?id)] - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) - e* (apply-type F2 A1) - a* (apply-type F2 A2) - [fixpoints** _] (check* fixpoints* e* a*)] - (return (&/T fixpoints** nil))) - state))) - ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) - ;; e* (apply-type F2 A1) - ;; a* (apply-type F2 A2) - ;; [fixpoints** _] (check* fixpoints* e* a*)] - ;; (return (&/T fixpoints** nil))) - - [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - (fn [state] - (matchv ::M/objects [((|do [F2 (deref ?id)] - (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - ((|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) - e* (apply-type F1 A1) - a* (apply-type F1 A2) - [fixpoints** _] (check* fixpoints* e* a*)] - (return (&/T fixpoints** nil))) - state))) - ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) - ;; e* (apply-type F1 A1) - ;; a* (apply-type F1 A2) - ;; [fixpoints** _] (check* fixpoints* e* a*)] - ;; (return (&/T fixpoints** nil))) - - [["lux;AppT" [F A]] _] - (let [fp-pair (&/T expected actual) - _ (when (> (&/|length fixpoints) 40) - (println 'FIXPOINTS (->> (&/|keys fixpoints) - (&/|map (fn [pair] - (|let [[e a] pair] - (str (show-type e) ":+:" - (show-type a))))) - (&/|interpose "\n\n") - (&/fold str ""))) - (assert false))] - (matchv ::M/objects [(fp-get fp-pair fixpoints)] - [["lux;Some" ?]] - (if ? - (return (&/T fixpoints nil)) - (fail (check-error expected actual))) - - [["lux;None" _]] - (|do [expected* (apply-type F A)] - (check* (fp-put fp-pair true fixpoints) expected* actual)))) - - [_ ["lux;AppT" [F A]]] - (|do [actual* (apply-type F A)] - (check* fixpoints expected actual*)) - - [["lux;AllT" _] _] - (with-var - (fn [$arg] - (|do [expected* (apply-type expected $arg)] - (check* fixpoints expected* actual)))) - - [_ ["lux;AllT" _]] - (with-var - (fn [$arg] - (|do [actual* (apply-type actual $arg)] - (check* fixpoints expected actual*)))) - - [["lux;DataT" "boolean"] ["lux;DataT" "java.lang.Boolean"]] - (return (&/T fixpoints nil)) + (matchv ::M/objects [((|do [F2 (deref ?aid)] + (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + [fixpoints** _] (check* fixpoints* A1 A2)] + (return (&/T fixpoints** nil))) + state)))) + ;; (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + ;; _ (check* fixpoints A1 A2)] + ;; (return (&/T fixpoints nil))) + + [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + (fn [state] + (matchv ::M/objects [((|do [F1 (deref ?id)] + (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + state)] + [["lux;Right" [state* output]]] + (return* state* output) - [["lux;DataT" "byte"] ["lux;DataT" "java.lang.Byte"]] - (return (&/T fixpoints nil)) + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + e* (apply-type F2 A1) + a* (apply-type F2 A2) + [fixpoints** _] (check* fixpoints* e* a*)] + (return (&/T fixpoints** nil))) + state))) + ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + ;; e* (apply-type F2 A1) + ;; a* (apply-type F2 A2) + ;; [fixpoints** _] (check* fixpoints* e* a*)] + ;; (return (&/T fixpoints** nil))) + + [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + (fn [state] + (matchv ::M/objects [((|do [F2 (deref ?id)] + (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state)] + [["lux;Right" [state* output]]] + (return* state* output) - [["lux;DataT" "short"] ["lux;DataT" "java.lang.Short"]] - (return (&/T fixpoints nil)) + [["lux;Left" _]] + ((|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + e* (apply-type F1 A1) + a* (apply-type F1 A2) + [fixpoints** _] (check* fixpoints* e* a*)] + (return (&/T fixpoints** nil))) + state))) + ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + ;; e* (apply-type F1 A1) + ;; a* (apply-type F1 A2) + ;; [fixpoints** _] (check* fixpoints* e* a*)] + ;; (return (&/T fixpoints** nil))) + + [["lux;AppT" [F A]] _] + (let [fp-pair (&/T expected actual) + _ (when (> (&/|length fixpoints) 40) + (println 'FIXPOINTS (->> (&/|keys fixpoints) + (&/|map (fn [pair] + (|let [[e a] pair] + (str (show-type e) ":+:" + (show-type a))))) + (&/|interpose "\n\n") + (&/fold str ""))) + (assert false))] + (matchv ::M/objects [(fp-get fp-pair fixpoints)] + [["lux;Some" ?]] + (if ? + (return (&/T fixpoints nil)) + (fail (check-error expected actual))) + + [["lux;None" _]] + (|do [expected* (apply-type F A)] + (check* (fp-put fp-pair true fixpoints) expected* actual)))) + + [_ ["lux;AppT" [F A]]] + (|do [actual* (apply-type F A)] + (check* fixpoints expected actual*)) + + [["lux;AllT" _] _] + (with-var + (fn [$arg] + (|do [expected* (apply-type expected $arg)] + (check* fixpoints expected* actual)))) + + [_ ["lux;AllT" _]] + (with-var + (fn [$arg] + (|do [actual* (apply-type actual $arg)] + (check* fixpoints expected actual*)))) + + [["lux;DataT" "boolean"] ["lux;DataT" "java.lang.Boolean"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "int"] ["lux;DataT" "java.lang.Integer"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "byte"] ["lux;DataT" "java.lang.Byte"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "long"] ["lux;DataT" "java.lang.Long"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "short"] ["lux;DataT" "java.lang.Short"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "float"] ["lux;DataT" "java.lang.Float"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "int"] ["lux;DataT" "java.lang.Integer"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "double"] ["lux;DataT" "java.lang.Double"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "long"] ["lux;DataT" "java.lang.Long"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "char"] ["lux;DataT" "java.lang.Character"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "float"] ["lux;DataT" "java.lang.Float"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Boolean"] ["lux;DataT" "boolean"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "double"] ["lux;DataT" "java.lang.Double"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Byte"] ["lux;DataT" "byte"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "char"] ["lux;DataT" "java.lang.Character"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Short"] ["lux;DataT" "short"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "java.lang.Boolean"] ["lux;DataT" "boolean"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Integer"] ["lux;DataT" "int"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "java.lang.Byte"] ["lux;DataT" "byte"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Long"] ["lux;DataT" "long"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "java.lang.Short"] ["lux;DataT" "short"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Float"] ["lux;DataT" "float"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "java.lang.Integer"] ["lux;DataT" "int"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Double"] ["lux;DataT" "double"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "java.lang.Long"] ["lux;DataT" "long"]] + (return (&/T fixpoints nil)) - [["lux;DataT" "java.lang.Character"] ["lux;DataT" "char"]] - (return (&/T fixpoints nil)) + [["lux;DataT" "java.lang.Float"] ["lux;DataT" "float"]] + (return (&/T fixpoints nil)) - [["lux;DataT" e!name] ["lux;DataT" a!name]] - (if (or (= e!name a!name) - (.isAssignableFrom (Class/forName e!name) (Class/forName a!name))) + [["lux;DataT" "java.lang.Double"] ["lux;DataT" "double"]] (return (&/T fixpoints nil)) - (fail (str "[Type Error] Names don't match: " e!name " & " a!name))) - - [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] - (|do [[fixpoints* _] (check* fixpoints aI eI)] - (check* fixpoints* eO aO)) - - [["lux;TupleT" e!members] ["lux;TupleT" a!members]] - (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* fp e a)] - (return fp*))) - fixpoints - e!members a!members)] - (return (&/T fixpoints* nil))) - - [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]] - (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] - (|let [[e!name e!type] e!case - [a!name a!type] a!case] - (if (= e!name a!name) - (|do [[fp* _] (check* fp e!type a!type)] - (return fp*)) - (fail (check-error expected actual))))) - fixpoints - e!cases a!cases)] - (return (&/T fixpoints* nil))) - - [["lux;RecordT" e!slots] ["lux;RecordT" a!slots]] - (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] - (|let [[e!name e!type] e!slot - [a!name a!type] a!slot] - (if (= e!name a!name) - (|do [[fp* _] (check* fp e!type a!type)] - (return fp*)) - (fail (check-error expected actual))))) - fixpoints - e!slots a!slots)] - (return (&/T fixpoints* nil))) - - [["lux;ExT" e!id] ["lux;ExT" a!id]] - (if (= e!id a!id) + + [["lux;DataT" "java.lang.Character"] ["lux;DataT" "char"]] (return (&/T fixpoints nil)) - (check-error expected actual)) - [_ _] - (fail (println-str "[Type Error] Can't type-check: " (show-type expected) (show-type actual))) - )) + [["lux;DataT" e!name] ["lux;DataT" a!name]] + (if (or (.equals ^Object e!name a!name) + (.isAssignableFrom (Class/forName e!name) (Class/forName a!name))) + (return (&/T fixpoints nil)) + (fail (str "[Type Error] Names don't match: " e!name " & " a!name))) + + [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] + (|do [[fixpoints* _] (check* fixpoints aI eI)] + (check* fixpoints* eO aO)) + + [["lux;TupleT" e!members] ["lux;TupleT" a!members]] + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* fp e a)] + (return fp*))) + fixpoints + e!members a!members)] + (return (&/T fixpoints* nil))) + + [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]] + (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] + (|let [[e!name e!type] e!case + [a!name a!type] a!case] + (if (.equals ^Object e!name a!name) + (|do [[fp* _] (check* fp e!type a!type)] + (return fp*)) + (fail (check-error expected actual))))) + fixpoints + e!cases a!cases)] + (return (&/T fixpoints* nil))) + + [["lux;RecordT" e!slots] ["lux;RecordT" a!slots]] + (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] + (|let [[e!name e!type] e!slot + [a!name a!type] a!slot] + (if (.equals ^Object e!name a!name) + (|do [[fp* _] (check* fp e!type a!type)] + (return fp*)) + (fail (check-error expected actual))))) + fixpoints + e!slots a!slots)] + (return (&/T fixpoints* nil))) + + [["lux;ExT" e!id] ["lux;ExT" a!id]] + (if (.equals ^Object e!id a!id) + (return (&/T fixpoints nil)) + (check-error expected actual)) + + [_ _] + (fail (println-str "[Type Error] Can't type-check: " (show-type expected) (show-type actual))) + ))) (defn check [expected actual] (|do [_ (check* init-fixpoints expected actual)] -- cgit v1.2.3 From 639c9385219e143fd7a6161c57fda34293b81055 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 26 May 2015 22:35:58 -0400 Subject: - Now using an in-memory class-loader. --- source/lux.lux | 6 ++++-- src/lux/base.clj | 35 +++++++++++++++++++++++++++++------ src/lux/compiler/base.clj | 26 +++++++++++++++++--------- src/lux/type.clj | 2 +- 4 files changed, 51 insertions(+), 18 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index ac47e81eb..ac28bf372 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -206,11 +206,13 @@ ## (deftype HostState ## (& #writer (^ org.objectweb.asm.ClassWriter) -## #loader (^ java.net.URLClassLoader))) +## #loader (^ java.net.URLClassLoader) +## #classes (^ clojure.lang.Atom))) (_lux_def HostState (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - #Nil])]))) + (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] + #Nil])])]))) ## (deftype (DefData' m) ## (| #TypeD diff --git a/src/lux/base.clj b/src/lux/base.clj index 7f551cdb0..c4aab9ec6 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -15,8 +15,9 @@ (def $NAME 3) ;; Host -(def $LOADER 0) -(def $WRITER 1) +(def $CLASSES 0) +(def $LOADER 1) +(def $WRITER 2) ;; CompilerState (def $ENVS 0) @@ -422,6 +423,10 @@ (fn [state] (return* state (->> state (get$ $HOST) (get$ $LOADER))))) +(def classes + (fn [state] + (return* state (->> state (get$ $HOST) (get$ $CLASSES))))) + (def +init-bindings+ (R ;; "lux;counter" 0 @@ -439,11 +444,29 @@ name )) +(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String + (class (byte-array [])) + Integer/TYPE + Integer/TYPE])) + (.setAccessible true))] + (defn memory-class-loader [store] + (proxy [java.lang.ClassLoader] + [] + (findClass [^String class-name] + ;; (prn 'findClass class-name) + (if-let [bytecode (get @store class-name)] + (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) + (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))) + (defn host [_] - (R ;; "lux;loader" - (-> (java.io.File. "./output/") .toURL vector into-array java.net.URLClassLoader.) - ;; "lux;writer" - (V "lux;None" nil))) + (let [store (atom {})] + (R ;; "lux;classes" + store + ;; "lux;loader" + (memory-class-loader store) + ;; (-> (java.io.File. "./output/") .toURL vector into-array java.net.URLClassLoader.) + ;; "lux;writer" + (V "lux;None" nil)))) (defn init-state [_] (R ;; "lux;envs" diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index a7886ab48..24f342469 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -15,18 +15,26 @@ (def closure-prefix "c") (def apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") -(defn write-file [^String file ^bytes data] - (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))] - (.write stream data))) +;; (defn write-file [^String file ^bytes data] +;; (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))] +;; (.write stream data))) -(defn write-class [name data] - (write-file (str "output/" name ".class") data)) +;; (defn write-class [name data] +;; (write-file (str "output/" name ".class") data)) (defn load-class! [^ClassLoader loader name] (.loadClass loader name)) +;; (defn save-class! [name bytecode] +;; (|do [loader &/loader +;; :let [_ (write-class name bytecode) +;; _ (load-class! loader (string/replace name #"/" "."))]] +;; (return nil))) + (defn save-class! [name bytecode] - (|do [loader &/loader - :let [_ (write-class name bytecode) - _ (load-class! loader (string/replace name #"/" "."))]] - (return nil))) + (let [real-name (string/replace name #"/" ".")] + (|do [loader &/loader + !classes &/classes + :let [_ (swap! !classes assoc real-name bytecode) + _ (load-class! loader real-name)]] + (return nil)))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 25e3e1053..d5be5a7c6 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -126,7 +126,7 @@ (&/V "lux;RecordT" (&/|list (&/T "lux;writer" (&/V "lux;DataT" "org.objectweb.asm.ClassWriter")) (&/T "lux;loader" (&/V "lux;DataT" "java.lang.ClassLoader")) - ))) + (&/T "lux;classes" (&/V "lux;DataT" "clojure.lang.Atom"))))) (def DefData* (fAll "lux;DefData'" "" -- cgit v1.2.3 From 5e45ec0419293fdde30cc9e3f0326e44ddd7442a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 27 May 2015 00:57:57 -0400 Subject: - _jvm_program now relies on the (IO (,)) type. - The command-line params argument in jvm_program is now transformed from a String array into (List Text). --- source/lux.lux | 13 ++++---- source/program.lux | 5 +-- src/lux/analyser/host.clj | 2 +- src/lux/compiler/host.clj | 83 +++++++++++++++++++++++++++++++++++++++++++---- src/lux/type.clj | 4 +++ 5 files changed, 90 insertions(+), 17 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index ac28bf372..bce5c421a 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1970,12 +1970,14 @@ )) (def #export (print x) - (-> Text (,)) - (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) [x])) + (-> Text (IO (,))) + (lambda [_] + (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [x]) + []))) (def #export (println x) - (-> Text (,)) + (-> Text (IO (,))) (print (text:++ x "\n"))) (def #export (some f xs) @@ -2065,8 +2067,7 @@ (let [[sname stype] slot [module name] (split-slot sname)] [($tag [module name]) ($symbol ["" name])]))) - slots)) - _ (println (text:++ "Using pattern: " (syntax:show pattern)))] + slots))] (#Right [state (: (List Syntax) (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) diff --git a/source/program.lux b/source/program.lux index cefec07d4..364c57d89 100644 --- a/source/program.lux +++ b/source/program.lux @@ -12,7 +12,4 @@ (filter p xs')))) (_jvm_program _ - (exec (println "Hello, world!") - (|> (int:+ 2 2) ->text ($ text:++ "2 + 2 = ") println) - (println (->text (using Int:Ord - (< 5 10)))))) + (println "Hello, world!")) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 9f80c43cc..182eb9ebb 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -246,5 +246,5 @@ (defn analyse-jvm-program [analyse ?args ?body] (|do [=body (&/with-scope "" (&&env/with-local "" (&/V "lux;AppT" (&/T &type/List &type/Text)) - (analyse-1+ analyse ?body)))] + (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))] (return (&/|list (&/V "jvm-program" =body))))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 8782acfa5..87753dce3 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -474,11 +474,82 @@ (|do [^ClassWriter *writer* &/get-writer] (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) (.visitCode)) - (|do [main-writer &/get-writer + (|do [^MethodVisitor main-writer &/get-writer + :let [$loop (new Label) + $end (new Label) + _ (doto main-writer + ;; Tail: Begin + (.visitLdcInsn (int 2)) ;; S + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 0)) ;; VVI + (.visitLdcInsn "lux;Nil") ;; VVIT + (.visitInsn Opcodes/AASTORE) ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 1)) ;; VVI + (.visitInsn Opcodes/ACONST_NULL) ;; VVIN + (.visitInsn Opcodes/AASTORE) ;; V + ;; Tail: End + ;; Size: Begin + (.visitVarInsn Opcodes/ALOAD 0) ;; VA + (.visitInsn Opcodes/ARRAYLENGTH) ;; VI + ;; Size: End + ;; Loop: Begin + (.visitLabel $loop) + (.visitLdcInsn (int 1)) ;; VII + (.visitInsn Opcodes/ISUB) ;; VI + (.visitInsn Opcodes/DUP) ;; VII + (.visitJumpInsn Opcodes/IFLT $end) ;; VI + ;; Head: Begin + (.visitInsn Opcodes/DUP) ;; VII + (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA + (.visitInsn Opcodes/SWAP) ;; VIAI + (.visitInsn Opcodes/AALOAD) ;; VIO + (.visitInsn Opcodes/SWAP) ;; VOI + (.visitInsn Opcodes/DUP_X2) ;; IVOI + (.visitInsn Opcodes/POP) ;; IVO + ;; Head: End + ;; Tuple: Begin + (.visitLdcInsn (int 2)) ;; IVOS + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2 + (.visitInsn Opcodes/DUP_X1) ;; IV2O2 + (.visitInsn Opcodes/SWAP) ;; IV22O + (.visitLdcInsn (int 0)) ;; IV22OI + (.visitInsn Opcodes/SWAP) ;; IV22IO + (.visitInsn Opcodes/AASTORE) ;; IV2 + (.visitInsn Opcodes/DUP_X1) ;; I2V2 + (.visitInsn Opcodes/SWAP) ;; I22V + (.visitLdcInsn (int 1)) ;; I22VI + (.visitInsn Opcodes/SWAP) ;; I22IV + (.visitInsn Opcodes/AASTORE) ;; I2 + ;; Tuple: End + ;; Cons: Begin + (.visitLdcInsn (int 2)) ;; I2I + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; I2V + (.visitInsn Opcodes/DUP) ;; I2VV + (.visitLdcInsn (int 0)) ;; I2VVI + (.visitLdcInsn "lux;Cons") ;; I2VVIT + (.visitInsn Opcodes/AASTORE) ;; I2V + (.visitInsn Opcodes/DUP_X1) ;; IV2V + (.visitInsn Opcodes/SWAP) ;; IVV2 + (.visitLdcInsn (int 1)) ;; IVV2I + (.visitInsn Opcodes/SWAP) ;; IVVI2 + (.visitInsn Opcodes/AASTORE) ;; IV + ;; Cons: End + (.visitInsn Opcodes/SWAP) ;; VI + (.visitJumpInsn Opcodes/GOTO $loop) + ;; Loop: End + (.visitLabel $end) ;; VI + (.visitInsn Opcodes/POP) ;; V + (.visitVarInsn Opcodes/ASTORE (int 0)) ;; + )] _ (compile ?body) - :let [_ (doto ^MethodVisitor main-writer - (.visitInsn Opcodes/POP) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] + :let [_ (doto main-writer + (.visitInsn Opcodes/ACONST_NULL) + (.visitMethodInsn Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature))] + :let [_ (doto main-writer + (.visitInsn Opcodes/POP) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] (return nil))))) diff --git a/src/lux/type.clj b/src/lux/type.clj index d5be5a7c6..9034abb53 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -15,6 +15,10 @@ (def Unit (&/V "lux;TupleT" (&/|list))) (def $Void (&/V "lux;VariantT" (&/|list))) +(def IO + (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "IO" "a" + (&/V "lux;LambdaT" (&/T Unit (&/V "lux;BoundT" "a")))))) + (def List (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;List" "a" (&/V "lux;VariantT" (&/|list (&/T "lux;Nil" Unit) -- cgit v1.2.3 From 20889fab030a5ad8de94ae26afffbc4488c44a16 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 27 May 2015 01:17:41 -0400 Subject: - Now storing the hash of the source file as a final, static field of the generated class. --- src/lux/compiler.clj | 10 +++++++--- src/lux/reader.clj | 4 ++-- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index e491fbdfe..db2c92c42 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -349,12 +349,16 @@ (if (.equals ^Object name "lux") (return* state nil) (fail* "[Compiler Error] Can't redefine a module!")) - (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (let [file-name (str "source/" name ".lux") + file-content (slurp file-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (&host/->class name) nil "java/lang/Object" nil))] + (&host/->class name) nil "java/lang/Object" nil)) + _ (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil (hash file-content)) + .visitEnd)] (matchv ::M/objects [((&/exhaust% compiler-step) (->> state - (&/set$ &/$SOURCE (&reader/from (str "source/" name ".lux"))) + (&/set$ &/$SOURCE (&reader/from file-name file-content)) (&/set$ &/$ENVS (&/|list (&/env name))) (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %)) (&/update$ &/$MODULES #(&/|put name &a-module/init-module %))))] diff --git a/src/lux/reader.clj b/src/lux/reader.clj index b1fcc4740..fa5d659bf 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -124,8 +124,8 @@ (&/T (&/T file-name line-num column-num*) line))))) (&/V "No" (str "[Reader Error] Text failed: " text)))))) -(defn from [file-name] - (let [lines (&/->list (string/split-lines (slurp file-name)))] +(defn from [file-name file-content] + (let [lines (&/->list (string/split-lines file-content))] (&/|map (fn [line+line-num] (|let [[line-num line] line+line-num] (&/T (&/T file-name line-num 0) -- cgit v1.2.3 From 0952d5906d90f305e0604447d6b292204ba53711 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 31 May 2015 00:45:35 -0400 Subject: - Finished _jvm-interface_ & _jvm-class_. - The version of the compiler is now stored as a field in the compiled definitions. --- source/lux.lux | 207 +++++++++++++++++++++++++--------------------- src/lux/analyser.clj | 44 +++++----- src/lux/analyser/host.clj | 172 +++++++++++++++++++++++++++++++------- src/lux/analyser/lux.clj | 10 +-- src/lux/base.clj | 4 +- src/lux/compiler.clj | 29 +++++-- src/lux/compiler/host.clj | 84 ++++++++++++------- src/lux/compiler/lux.clj | 10 ++- src/lux/host.clj | 3 +- 9 files changed, 368 insertions(+), 195 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index bce5c421a..2e5752592 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -7,9 +7,17 @@ ## You must not remove this notice, or any other, from this software. ## First things first, must define functions -(_jvm_interface Function - (: (-> [java.lang.Object] java.lang.Object) - apply)) +(_jvm_interface "lux.Function" [] + (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## ( [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) ## Basic types (_lux_def Bool (#DataT "java.lang.Boolean")) @@ -577,7 +585,7 @@ _ (fail "Wrong syntax for $'"))) -(def' #export (fold f init xs) +(def' #export (foldL f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) @@ -588,37 +596,50 @@ init (#Cons [x xs']) - (fold f (f init x) xs'))) + (foldL f (f init x) xs'))) + +(def' #export (foldR f init xs) + (All' [a b] + (->' (->' (B' b) (B' a) (B' a)) + (B' a) + ($' List (B' b)) + (B' a))) + (_lux_case xs + #Nil + init + + (#Cons [x xs']) + (f x (foldR f init xs')))) (def' #export (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) - (fold (_lux_: (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda' [tail head] - (#Cons [head tail]))) - #Nil - list)) + (foldL (_lux_: (All' [a] + (->' ($' List (B' a)) (B' a) ($' List (B' a)))) + (lambda' [tail head] + (#Cons [head tail]))) + #Nil + list)) (defmacro #export (list xs) (return (_lux_: SyntaxList - (#Cons [(fold (lambda' [tail head] - (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) - (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) - (_meta (#TagS ["lux" "Nil"])) - (reverse xs)) + (#Cons [(foldL (lambda' [tail head] + (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) + (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) + (_meta (#TagS ["lux" "Nil"])) + (reverse xs)) #Nil])))) (defmacro #export (list& xs) (_lux_case (reverse xs) (#Cons [last init]) (return (_lux_: SyntaxList - (list (fold (lambda' [tail head] - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list head tail))))))) - last - init)))) + (list (foldL (lambda' [tail head] + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) + last + init)))) _ (fail "Wrong syntax for list&"))) @@ -642,13 +663,13 @@ (list ($form (list ($symbol ["" "_lux_lambda"]) ($symbol name) harg - (fold (lambda' [body' arg] - ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol ["" ""]) - arg - body'))) - body - (reverse targs)))))))) + (foldL (lambda' [body' arg] + ($form (list ($symbol ["" "_lux_lambda"]) + ($symbol ["" ""]) + arg + body'))) + body + (reverse targs)))))))) _ (fail "Wrong syntax for lambda")))) @@ -714,18 +735,18 @@ (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) (return (_lux_: SyntaxList - (list (fold (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (_lux_case binding - [label value] - (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) - body - (fold (_lux_: (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda [tail head] (#Cons [head tail]))) - #Nil - (as-pairs bindings)))))) + (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (_lux_case binding + [label value] + (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) + body + (foldL (_lux_: (All' [a] + (->' ($' List (B' a)) (B' a) ($' List (B' a)))) + (lambda [tail head] (#Cons [head tail]))) + #Nil + (as-pairs bindings)))))) _ (fail "Wrong syntax for let"))) @@ -790,9 +811,9 @@ (_lux_case tokens (#Cons [op (#Cons [init args])]) (return (_lux_: SyntaxList - (list (fold (lambda [a1 a2] ($form (list op a1 a2))) - init - args)))) + (list (foldL (lambda [a1 a2] ($form (list op a1 a2))) + init + args)))) _ (fail "Wrong syntax for $"))) @@ -887,16 +908,16 @@ (_lux_case tokens (#Cons [init apps]) (return (_lux_: SyntaxList - (list (fold (_lux_: (->' Syntax Syntax Syntax) - (lambda [acc app] - (_lux_case app - (#Meta [_ (#FormS parts)]) - ($form (list:++ parts (list acc))) + (list (foldL (_lux_: (->' Syntax Syntax Syntax) + (lambda [acc app] + (_lux_case app + (#Meta [_ (#FormS parts)]) + ($form (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc)))))) - init - apps)))) + _ + (`' ((~ app) (~ acc)))))) + init + apps)))) _ (fail "Wrong syntax for |>"))) @@ -974,10 +995,10 @@ (_lux_case (reverse tokens) (#Cons [output inputs]) (return (_lux_: SyntaxList - (list (fold (_lux_: (->' Syntax Syntax Syntax) - (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))) - output - inputs)))) + (list (foldL (_lux_: (->' Syntax Syntax Syntax) + (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))) + output + inputs)))) _ (fail "Wrong syntax for ->"))) @@ -989,20 +1010,20 @@ (defmacro (do tokens) (_lux_case tokens (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) - (let [body' (fold (_lux_: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (_lux_case var - (#Meta [_ (#TagS ["" "let"])]) - (`' (;let (~ value) (~ body'))) - - _ - (`' (;bind (_lux_lambda (~ ($symbol ["" ""])) - (~ var) - (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] + (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (_lux_case var + (#Meta [_ (#TagS ["" "let"])]) + (`' (;let (~ value) (~ body'))) + + _ + (`' (;bind (_lux_lambda (~ ($symbol ["" ""])) + (~ var) + (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] (return (_lux_: SyntaxList (list (`' (_lux_case (~ monad) {#;return ;return #;bind ;bind} @@ -1177,7 +1198,7 @@ (def'' #export (length list) (-> List Int) - (fold (lambda [acc _] (int:+ 1 acc)) 0 list)) + (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) (def'' #export (not x) (-> Bool Bool) @@ -1242,11 +1263,11 @@ (let [replacements (map (_lux_: (-> Text (, Text Syntax)) (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) (list& self-ident idents)) - body' (fold (_lux_: (-> Syntax Text Syntax) - (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) - (replace-syntax replacements body) - (reverse targs))] + body' (foldL (_lux_: (-> Syntax Text Syntax) + (lambda [body' arg'] + (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) + (replace-syntax replacements body) + (reverse targs))] (return (_lux_: SyntaxList (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) @@ -1318,7 +1339,7 @@ (def'' (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) - (fold list:++ #Nil xs)) + (foldL list:++ #Nil xs)) ## (def'' #export (normalize ident) ## (-> Ident ($' Lux Ident)) @@ -1431,10 +1452,10 @@ (text:++ "#" (ident->text ident)) (#Meta [_ (#TupleS members)]) - ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") + ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) "]") (#Meta [_ (#FormS members)]) - ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") + ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) ")") (#Meta [_ (#RecordS slots)]) ($ text:++ "{" @@ -1444,7 +1465,7 @@ (let [[k v] slot] ($ text:++ (syntax:show k) " " (syntax:show v)))))) (interpose " ") - (fold text:++ "")) + (foldL text:++ "")) "}") )) @@ -1491,10 +1512,10 @@ ($tuple (map walk-type members)) (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (fold (_lux_: (-> Syntax Syntax Syntax) - (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) - (walk-type type-fn) - (map walk-type args)) + (foldL (_lux_: (-> Syntax Syntax Syntax) + (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) + (walk-type type-fn) + (map walk-type args)) _ type)) @@ -1590,10 +1611,10 @@ (#Cons [value actions]) (let [dummy ($symbol ["" ""])] (return (_lux_: SyntaxList - (list (fold (: (-> Syntax Syntax Syntax) - (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) - value - actions))))) + (list (foldL (: (-> Syntax Syntax Syntax) + (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) + value + actions))))) _ (fail "Wrong syntax for exec"))) @@ -1914,10 +1935,10 @@ (case (reverse tokens) (\ (list& last init)) (return (: (List Syntax) - (list (fold (: (-> Syntax Syntax Syntax) - (lambda [post pre] (` ))) - last - init)))) + (list (foldL (: (-> Syntax Syntax Syntax) + (lambda [post pre] (` ))) + last + init)))) _ (fail )))] diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index ba0fe4e66..01a562bfe 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -412,42 +412,44 @@ (matchv ::M/objects [token] ;; Arrays [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] - ["lux;Nil" _]]]]]]]]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] + ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-new-array analyse ?class ?length) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Cons" [?elem - ["lux;Nil" _]]]]]]]]]]]]] + ["lux;Cons" [?array + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] + ["lux;Cons" [?elem + ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Nil" _]]]]]]]]]]] + ["lux;Cons" [?array + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] + ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?name]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?super-class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] - ["lux;Nil" _]]]]]]]]]]]]] - (&&host/analyse-jvm-class analyse ?name ?super-class ?fields) + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] + ?methods]]]]]]]]]]]]]] + (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?name]]]] - ?members]]]]]]]] - (&&host/analyse-jvm-interface analyse ?name ?members) + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] + ?methods]]]]]]]]]] + (&&host/analyse-jvm-interface analyse ?name ?supers ?methods) ;; Programs [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?args]]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?args]]]] + ["lux;Cons" [?body + ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-program analyse ?args ?body) [_] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 182eb9ebb..1aa683ea6 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -18,6 +18,14 @@ [_] (fail "[Analyser Error] Can't extract Symbol."))) +(defn ^:private extract-text [text] + (matchv ::M/objects [text] + [["lux;Meta" [_ ["lux;TextS" ?text]]]] + (return ?text) + + [_] + (fail "[Analyser Error] Can't extract Text."))) + (defn ^:private analyse-1+ [analyse ?token] (&type/with-var (fn [$var] @@ -112,9 +120,19 @@ analyse-jvm-invokevirtual "jvm-invokevirtual" analyse-jvm-invokeinterface "jvm-invokeinterface" - analyse-jvm-invokespecial "jvm-invokespecial" ) +(defn analyse-jvm-invokespecial [analyse ?class ?method ?classes ?object ?args] + (|do [=classes (&/map% &host/extract-jvm-param ?classes) + =return (if (= "" ?method) + (return &type/$Void) + (&host/lookup-virtual-method ?class ?method =classes)) + =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) + =args (&/map2% (fn [?c ?o] + (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) + =classes ?args)] + (return (&/|list (&/T (&/V "jvm-invokespecial" (&/T ?class ?method =classes =object =args)) =return))))) + (defn analyse-jvm-null? [analyse ?object] (|do [=object (&&/analyse-1 analyse ?object)] (return (&/|list (&/T (&/V "jvm-null?" =object) (&/V "lux;DataT" "java.lang.Boolean")))))) @@ -139,44 +157,134 @@ =array-type (&&/expr-type =array)] (return (&/|list (&/T (&/V "jvm-aaload" (&/T =array ?idx)) =array-type))))) -(defn analyse-jvm-class [analyse ?name ?super-class ?fields] - (|do [?fields (&/map% (fn [?field] +(defn ^:private analyse-modifiers [modifiers] + (&/fold% (fn [so-far modif] + (matchv ::M/objects [modif] + [["lux;Meta" [_ ["lux;TextS" "public"]]]] + (return (assoc so-far :visibility "public")) + + [["lux;Meta" [_ ["lux;TextS" "private"]]]] + (return (assoc so-far :visibility "private")) + + [["lux;Meta" [_ ["lux;TextS" "protected"]]]] + (return (assoc so-far :visibility "protected")) + + [["lux;Meta" [_ ["lux;TextS" "static"]]]] + (return (assoc so-far :static? true)) + + [["lux;Meta" [_ ["lux;TextS" "final"]]]] + (return (assoc so-far :final? true)) + + [["lux;Meta" [_ ["lux;TextS" "abstract"]]]] + (return (assoc so-far :abstract? true)) + + [["lux;Meta" [_ ["lux;TextS" "synchronized"]]]] + (return (assoc so-far :concurrency "synchronized")) + + [["lux;Meta" [_ ["lux;TextS" "volatile"]]]] + (return (assoc so-far :concurrency "volatile")) + + [_] + (fail (str "[Analyser Error] Unknown modifier: " (&/show-ast modif))))) + {:visibility "default" + :static? false + :final? false + :abstract? false + :concurrency nil} + modifiers)) + +(defn ^:private as-otype [tname] + (case tname + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + tname + )) + +(defn analyse-jvm-class [analyse ?name ?super-class ?interfaces ?fields ?methods] + (|do [=interfaces (&/map% extract-text ?interfaces) + =fields (&/map% (fn [?field] (matchv ::M/objects [?field] - [["lux;Meta" [_ ["lux;TupleS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?field-name]]] - ["lux;Nil" _]]]]]]]]] - (return [?class ?field-name]) + [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?field-name]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-type]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?field-modifiers]]] + ["lux;Nil" _]]]]]]]]]]] + (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] + (return {:name ?field-name + :modifiers =field-modifiers + :type ?field-type})) [_] - (fail "[Analyser Error] Fields must be Tuple2 of [Symbol, Symbol]"))) + (fail "[Analyser Error] Wrong syntax for field."))) ?fields) - :let [=fields (into {} (for [[class field] ?fields] - [field {:access :public - :type class}]))] - $module &/get-module-name] - (return (&/|list (&/V "jvm-class" (&/T $module ?name ?super-class =fields {})))))) - -(defn analyse-jvm-interface [analyse ?name ?members] - (|do [=members (&/map% (fn [member] - (matchv ::M/objects [member] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ":"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "->"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?inputs]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?output]]]] - ["lux;Nil" _]]]]]]]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?member-name]]]] - ["lux;Nil" _]]]]]]]]]]] - (|do [inputs* (&/map% extract-ident ?inputs)] - (return [?member-name [inputs* ?output]])) + =methods (&/map% (fn [?method] + (matchv ::M/objects [?method] + [[?idx ["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?method-name]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-inputs]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-output]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-modifiers]]] + ["lux;Cons" [?method-body + ["lux;Nil" _]]]]]]]]]]]]]]]] + (|do [=method-inputs (&/map% (fn [minput] + (matchv ::M/objects [minput] + [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?input-name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?input-type]]] + ["lux;Nil" _]]]]]]]]] + (return (&/T (&/ident->text ?input-name) ?input-type)) + + [_] + (fail "[Analyser Error] Wrong syntax for method."))) + ?method-inputs) + =method-modifiers (analyse-modifiers ?method-modifiers) + =method-body (&/with-scope (str ?name "_" ?idx) + (&/fold (fn [body* input*] + (|let [[iname itype] input*] + (&&env/with-local iname (&/V "lux;DataT" (as-otype itype)) + body*))) + (if (= "void" ?method-output) + (analyse-1+ analyse ?method-body) + (&&/analyse-1 analyse (&/V "lux;DataT" (as-otype ?method-output)) ?method-body)) + (&/|reverse (if (:static? =method-modifiers) + =method-inputs + (&/|cons (&/T ";this" ?super-class) + =method-inputs)))))] + (return {:name ?method-name + :modifiers =method-modifiers + :inputs (&/|map &/|second =method-inputs) + :output ?method-output + :body =method-body})) + + [_] + (fail "[Analyser Error] Wrong syntax for method."))) + (&/enumerate ?methods))] + (return (&/|list (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))))) + +(defn analyse-jvm-interface [analyse ?name ?supers ?methods] + (|do [=supers (&/map% extract-text ?supers) + =methods (&/map% (fn [method] + (matchv ::M/objects [method] + [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?method-name]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?inputs]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?output]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?modifiers]]] + ["lux;Nil" _]]]]]]]]]]]]] + (|do [=inputs (&/map% extract-text ?inputs) + =modifiers (analyse-modifiers ?modifiers)] + (return {:name ?method-name + :modifiers =modifiers + :inputs =inputs + :output ?output})) [_] (fail "[Analyser Error] Invalid method signature!"))) - ?members) - :let [=methods (into {} (for [[method [inputs output]] (&/->seq =members)] - [method {:access :public - :type [inputs output]}]))] - $module &/get-module-name] - (return (&/|list (&/V "jvm-interface" (&/T $module ?name =methods)))))) + ?methods)] + (return (&/|list (&/V "jvm-interface" (&/T ?name =supers =methods)))))) (defn analyse-jvm-try [analyse ?body [?catches ?finally]] (|do [=body (&&/analyse-1 analyse ?body) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index dff936fbe..cdecd234f 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -329,14 +329,12 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (matchv ::M/objects [=value] - [[?expr ?expr-type]] - (return (&/|list (&/T ?expr ==type)))))) + (return (&/|list (&/T (&/V "ann" (&/T =value =type)) + ==type))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) =value (&&/analyse-1 analyse ==type ?value)] - (matchv ::M/objects [=value] - [[?expr ?expr-type]] - (return (&/|list (&/T ?expr ==type)))))) + (return (&/|list (&/T (&/V "ann" (&/T =value =type)) + ==type))))) diff --git a/src/lux/base.clj b/src/lux/base.clj index c4aab9ec6..57b25f47e 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -454,7 +454,7 @@ [] (findClass [^String class-name] ;; (prn 'findClass class-name) - (if-let [bytecode (get @store class-name)] + (if-let [^bytes bytecode (get @store class-name)] (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))) @@ -652,7 +652,7 @@ [_ _] false)) -(defn enumerate* [idx xs] +(defn ^:private enumerate* [idx xs] (matchv ::M/objects [xs] [["lux;Cons" [x xs*]]] (V "lux;Cons" (T (T idx x) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index db2c92c42..a0425cdbe 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -25,6 +25,9 @@ ClassWriter MethodVisitor))) +;; [Constants] +(def ^:private version "0.2") + ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] (matchv ::M/objects [syntax] @@ -72,6 +75,9 @@ [["lambda" [?scope ?env ?body]]] (&&lambda/compile-lambda compile-expression ?scope ?env ?body) + [["ann" [?value-ex ?type-ex]]] + (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) + ;; Integer arithmetic [["jvm-iadd" [?x ?y]]] (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) @@ -308,11 +314,11 @@ [["jvm-program" ?body]] (&&host/compile-jvm-program compile-expression ?body) - [["jvm-interface" [?package ?name ?methods]]] - (&&host/compile-jvm-interface compile-expression ?package ?name ?methods) + [["jvm-interface" [?name ?supers ?methods]]] + (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - [["jvm-class" [?package ?name ?super-class ?fields ?methods]]] - (&&host/compile-jvm-class compile-expression ?package ?name ?super-class ?fields ?methods))) + [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] + (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) (defn ^:private eval! [expr] (|do [id &/gen-id @@ -353,9 +359,18 @@ file-content (slurp file-name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (&host/->class name) nil "java/lang/Object" nil)) - _ (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil (hash file-content)) - .visitEnd)] + (&host/->class name) nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil (hash file-content)) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil version) + .visitEnd) + ;; (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil ...) + ;; .visitEnd) + ;; (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_exports" "Ljava/lang/String;" nil ...) + ;; .visitEnd) + ;; (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_macros" "Ljava/lang/String;" nil ...) + ;; .visitEnd) + )] (matchv ::M/objects [((&/exhaust% compiler-step) (->> state (&/set$ &/$SOURCE (&reader/from file-name file-content)) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 87753dce3..e825ca0ad 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -238,7 +238,7 @@ (defn compile-jvm-new [compile *type* ?class ?classes ?args] (|do [^MethodVisitor *writer* &/get-writer - :let [init-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")V") + :let [init-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")V") class* (&host/->class ?class) _ (doto *writer* (.visitTypeInsn Opcodes/NEW class*) @@ -247,7 +247,7 @@ (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] (return ret))) - (map vector ?classes ?args)) + (&/zip2 ?classes ?args)) :let [_ (doto *writer* (.visitMethodInsn Opcodes/INVOKESPECIAL class* "" init-sig))]] (return nil))) @@ -303,40 +303,62 @@ :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]] (return nil))) -(defn compile-jvm-class [compile ?package ?name ?super-class ?fields ?methods] - (let [parent-dir (&host/->package ?package) - full-name (str parent-dir "/" ?name) +(defn ^:private modifiers->int [mods] + (+ (case (:visibility mods) + "default" 0 + "public" Opcodes/ACC_PUBLIC + "private" Opcodes/ACC_PRIVATE + "protected" Opcodes/ACC_PROTECTED) + (if (:static? mods) Opcodes/ACC_STATIC 0) + (if (:final? mods) Opcodes/ACC_FINAL 0) + (if (:abstract? mods) Opcodes/ACC_ABSTRACT 0) + (case (:concurrency mods) + "synchronized" Opcodes/ACC_SYNCHRONIZED + "volatile" Opcodes/ACC_VOLATILE + ;; else + 0))) + +(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods] + (let [name* (&host/->class ?name) super-class* (&host/->class ?super-class) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - full-name nil super-class* nil)) - _ (do (doseq [[field props] ?fields] - (doto (.visitField =class Opcodes/ACC_PUBLIC field (&host/->type-signature (:type props)) nil nil) - (.visitEnd))) - (doto (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL super-class* "" "()V") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)) - (.visitEnd =class) - (.mkdirs (java.io.File. (str "output/" parent-dir))))] - (&&/save-class! full-name (.toByteArray =class)))) - -(defn compile-jvm-interface [compile ?package ?name ?methods] - (let [parent-dir (&host/->package ?package) - full-name (str parent-dir "/" ?name) + name* nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) + (&host/->type-signature (:type field)) nil nil) + (.visitEnd))) + ?fields)] + (|do [_ (&/map% (fn [method] + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (&/with-writer (.visitMethod =class (modifiers->int (:modifiers method)) + (:name method) + signature nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (.visitCode =method)] + _ (compile (:body method)) + :let [_ (doto =method + (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + ?methods)] + (&&/save-class! name* (.toByteArray (doto =class .visitEnd)))))) + +(defn compile-jvm-interface [compile ?name ?supers ?methods] + (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) + (let [name* (&host/->class ?name) =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) - full-name nil "java/lang/Object" nil)) - _ (do (doseq [[?method ?props] ?methods - :let [[?args ?return] (:type ?props) - signature (str "(" (&/fold str "" (&/|map &host/->type-signature ?args)) ")" (&host/->type-signature ?return))]] - (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil)) - (.visitEnd =interface) - (.mkdirs (java.io.File. (str "output/" parent-dir))))] - (&&/save-class! full-name (.toByteArray =interface)))) + name* nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))) + _ (do (&/|map (fn [method] + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (.visitMethod =interface (modifiers->int (:modifiers method)) (:name method) signature nil nil))) + ?methods) + (.visitEnd =interface))] + (&&/save-class! name* (.toByteArray =interface)))) (defn compile-jvm-try [compile *type* ?body ?catches ?finally] (|do [^MethodVisitor *writer* &/get-writer diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index cf4a65f04..d0caff173 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -135,7 +135,12 @@ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) current-class nil "java/lang/Object" (into-array ["lux/Function"])) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) - (doto (.visitEnd))))] + (doto (.visitEnd))) + ;; (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_mode" datum-sig nil ...) + ;; (doto (.visitEnd))) + ;; (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_type" datum-sig nil nil) + ;; (doto (.visitEnd))) + )] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (|do [^MethodVisitor **writer** &/get-writer :let [_ (.visitCode **writer**)] @@ -150,6 +155,9 @@ _ (&&/save-class! current-class (.toByteArray =class))] (return nil))) +(defn compile-ann [compile *type* ?value-ex ?type-ex] + (compile ?value-ex)) + (defn compile-declare-macro [compile module name] (|do [_ (&a-module/declare-macro module name)] (return nil))) diff --git a/src/lux/host.clj b/src/lux/host.clj index 8817ea338..e2efd92e9 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -25,8 +25,7 @@ ))) (defn ^:private method->type [^Method method] - (|do [=return (class->type (.getReturnType method))] - (return =return))) + (class->type (.getReturnType method))) ;; [Resources] (defn ^String ->class [class] -- cgit v1.2.3 From 81e1a4f10ad7aa7cfd76f9877e5e7deacb2d441e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 9 Jun 2015 22:37:56 -0400 Subject: - Put definition metadata into the generated .class files. --- source/lux.lux | 29 ++------- src/lux/compiler/lux.clj | 152 +++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 152 insertions(+), 29 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 2e5752592..2a4cc8660 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1341,33 +1341,16 @@ (-> ($' List ($' List a)) ($' List a))) (foldL list:++ #Nil xs)) -## (def'' #export (normalize ident) -## (-> Ident ($' Lux Ident)) -## (_lux_case ident -## ["" name] -## (do Lux:Monad -## [module-name get-module-name] -## (;return (: Ident [module-name name]))) - -## _ -## (return ident))) -(def'' #export (normalize ident state) +(def'' #export (normalize ident) (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] - (_lux_case state - {#source source #modules modules #module-aliases module-aliases - #envs envs #types types #host host - #seed seed} - (_lux_case (reverse envs) - #Nil - (#Left "Can't normalize Ident without a global environment.") - - (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) - (#Right [state [prefix name]]))) - + (do Lux:Monad + [module-name get-module-name] + (;return (_lux_: Ident [module-name name]))) + _ - (#Right [state ident]))) + (return ident))) (defmacro #export (| tokens) (do Lux:Monad diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index d0caff173..b47267d25 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -124,6 +124,147 @@ :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature)]] (return nil))) +(defn ^:private type->analysis [type] + (matchv ::M/objects [type] + [["lux;DataT" ?class]] + (&/T (&/V "variant" (&/T "lux;DataT" + (&/T (&/V "text" ?class) &type/$Void))) + &type/$Void) + + [["lux;TupleT" ?members]] + (&/T (&/V "variant" (&/T "lux;TupleT" + (&/fold (fn [tail head] + (&/V "variant" (&/T "lux;Cons" + (&/T (&/V "tuple" (&/|list (type->analysis head) + tail)) + &type/$Void)))) + (&/V "variant" (&/T "lux;Nil" + (&/T (&/V "tuple" (&/|list)) + &type/$Void))) + (&/|reverse ?members)))) + &type/$Void) + + [["lux;VariantT" ?cases]] + (&/T (&/V "variant" (&/T "lux;VariantT" + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (&/V "variant" (&/T "lux;Cons" + (&/T (&/V "tuple" (&/|list (&/T (&/V "tuple" (&/|list (&/T (&/V "text" hlabel) &type/$Void) + (type->analysis htype))) + &type/$Void) + tail)) + &type/$Void))))) + (&/V "variant" (&/T "lux;Nil" + (&/T (&/V "tuple" (&/|list)) + &type/$Void))) + (&/|reverse ?cases)))) + &type/$Void) + + [["lux;RecordT" ?slots]] + (&/T (&/V "variant" (&/T "lux;RecordT" + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (&/V "variant" (&/T "lux;Cons" + (&/T (&/V "tuple" (&/|list (&/T (&/V "tuple" (&/|list (&/T (&/V "text" hlabel) &type/$Void) + (type->analysis htype))) + &type/$Void) + tail)) + &type/$Void))))) + (&/V "variant" (&/T "lux;Nil" + (&/T (&/V "tuple" (&/|list)) + &type/$Void))) + (&/|reverse ?slots)))) + &type/$Void) + + [["lux;LambdaT" [?input ?output]]] + (&/T (&/V "variant" (&/T "lux;LambdaT" + (&/T (&/V "tuple" (&/|map type->analysis (&/|list ?input ?output))) + &type/$Void))) + &type/$Void) + + [["lux;AllT" [?env ?name ?arg ?body]]] + (&/T (&/V "variant" (&/T "lux;AllT" + (&/T (&/V "tuple" (&/|list (matchv ::M/objects [?env] + [["lux;None" _]] + (&/V "variant" (&/T "lux;Some" + (&/T (&/V "tuple" (&/|list)) + &type/$Void))) + + [["lux;Some" ??env]] + (&/V "variant" (&/T "lux;Some" + (&/T (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (&/V "variant" (&/T "lux;Cons" + (&/T (&/V "tuple" (&/|list (&/T (&/V "tuple" (&/|list (&/T (&/V "text" hlabel) &type/$Void) + (type->analysis htype))) + &type/$Void) + tail)) + &type/$Void))))) + (&/V "variant" (&/T "lux;Nil" + (&/T (&/V "tuple" (&/|list)) + &type/$Void))) + (&/|reverse ??env)) + &type/$Void)))) + (&/T (&/V "text" ?name) &type/$Void) + (&/T (&/V "text" ?arg) &type/$Void) + (type->analysis ?body))) + &type/$Void))) + &type/$Void) + + [["lux;BoundT" ?name]] + (&/T (&/V "variant" (&/T "lux;BoundT" + (&/T (&/V "text" ?name) &type/$Void))) + &type/$Void) + + [["lux;AppT" [?fun ?arg]]] + (&/T (&/V "variant" (&/T "lux;AppT" + (&/T (&/V "tuple" (&/|map type->analysis (&/|list ?fun ?arg))) + &type/$Void))) + &type/$Void) + )) + +(defn ^:private compile-def-type [compile ?body ?def-data] + (|do [^MethodVisitor **writer** &/get-writer] + (matchv ::M/objects [?def-data] + [["lux;TypeD" _]] + (let [_ (doto **writer** + ;; Tail: Begin + (.visitLdcInsn (int 2)) ;; S + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 0)) ;; VVI + (.visitLdcInsn "lux;TypeD") ;; VVIT + (.visitInsn Opcodes/AASTORE) ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 1)) ;; VVI + (.visitInsn Opcodes/ACONST_NULL) ;; VVIN + (.visitInsn Opcodes/AASTORE) ;; V + )] + (return nil)) + + [["lux;ValueD" _]] + (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) + [?def-value ?def-type] (matchv ::M/objects [?body] + [[["ann" [?def-value ?type-expr]] ?def-type]] + (&/T ?def-value ?type-expr) + + [[?def-value ?def-type]] + (&/T ?body (type->analysis ?def-type)))] + (|do [:let [_ (doto **writer** + (.visitLdcInsn (int 2)) ;; S + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 0)) ;; VVI + (.visitLdcInsn "lux;ValueD") ;; VVIT + (.visitInsn Opcodes/AASTORE) ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 1)) ;; VVI + )] + _ (compile ?def-type) + :let [_ (.visitInsn **writer** Opcodes/AASTORE)]] + (return nil))) + ))) + (defn compile-def [compile ?name ?body ?def-data] (|do [^ClassWriter *writer* &/get-writer module-name &/get-module-name @@ -136,17 +277,16 @@ current-class nil "java/lang/Object" (into-array ["lux/Function"])) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) (doto (.visitEnd))) - ;; (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_mode" datum-sig nil ...) - ;; (doto (.visitEnd))) - ;; (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_type" datum-sig nil nil) - ;; (doto (.visitEnd))) - )] + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_meta" datum-sig nil nil) + (doto (.visitEnd))))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (|do [^MethodVisitor **writer** &/get-writer :let [_ (.visitCode **writer**)] _ (compile ?body) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_datum" datum-sig)] + _ (compile-def-type compile ?body ?def-data) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_meta" datum-sig)] :let [_ (doto **writer** - (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))]] -- cgit v1.2.3 From cf337fae7217a85ae7700349f5f0967b09a86c28 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 9 Jun 2015 22:58:29 -0400 Subject: - Now displaying the location where the analyser finds error (file-name, line & column). --- src/lux/analyser.clj | 440 ++++++++++++++++++++++++++------------------------- src/lux/reader.clj | 6 +- src/lux/type.clj | 2 +- 3 files changed, 229 insertions(+), 219 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 01a562bfe..a89d37ee5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -2,7 +2,7 @@ (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [|do return fail return* fail* |list]] + (lux [base :as & :refer [|let |do return fail return* fail* |list]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -15,51 +15,51 @@ (defn ^:private parse-handler [[catch+ finally+] token] (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_catch"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-arg]]]] - ["lux;Cons" [?catch-body - ["lux;Nil" _]]]]]]]]]]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-arg]]]] + ["lux;Cons" [?catch-body + ["lux;Nil" _]]]]]]]]]]]]] (&/T (&/|++ catch+ (|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_finally"]]]] - ["lux;Cons" [?finally-body - ["lux;Nil" _]]]]]]]]] + ["lux;Cons" [?finally-body + ["lux;Nil" _]]]]]]]]] (&/T catch+ ?finally-body))) (let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (|list))))] (defn ^:private aba1 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Standard special forms - [["lux;Meta" [meta ["lux;BoolS" ?value]]]] + [["lux;BoolS" ?value]] (|do [_ (&type/check exo-type &type/Bool)] (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - [["lux;Meta" [meta ["lux;IntS" ?value]]]] + [["lux;IntS" ?value]] (|do [_ (&type/check exo-type &type/Int)] (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - [["lux;Meta" [meta ["lux;RealS" ?value]]]] + [["lux;RealS" ?value]] (|do [_ (&type/check exo-type &type/Real)] (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - [["lux;Meta" [meta ["lux;CharS" ?value]]]] + [["lux;CharS" ?value]] (|do [_ (&type/check exo-type &type/Char)] (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - [["lux;Meta" [meta ["lux;TextS" ?value]]]] + [["lux;TextS" ?value]] (|do [_ (&type/check exo-type &type/Text)] (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - [["lux;Meta" [meta ["lux;TupleS" ?elems]]]] + [["lux;TupleS" ?elems]] (&&lux/analyse-tuple analyse exo-type ?elems) - [["lux;Meta" [meta ["lux;RecordS" ?elems]]]] + [["lux;RecordS" ?elems]] (&&lux/analyse-record analyse exo-type ?elems) - [["lux;Meta" [meta ["lux;TagS" ?ident]]]] + [["lux;TagS" ?ident]] (&&lux/analyse-variant analyse exo-type ?ident unit) - [["lux;Meta" [meta ["lux;SymbolS" [_ "_jvm_null"]]]]] + [["lux;SymbolS" [_ "_jvm_null"]]] (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) [_] @@ -68,51 +68,51 @@ (defn ^:private aba2 [analyse eval! exo-type token] (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;SymbolS" ?ident]]]] + [["lux;SymbolS" ?ident]] (&&lux/analyse-symbol analyse exo-type ?ident) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]] - ["lux;Cons" [?value ?branches]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]] + ["lux;Cons" [?value ?branches]]]]]] (&&lux/analyse-case analyse exo-type ?value ?branches) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]] + ["lux;Cons" [?body + ["lux;Nil" _]]]]]]]]]]] (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]]]] (&&lux/analyse-def analyse ?name ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] + ["lux;Nil" _]]]]]]] (&&lux/analyse-declare-macro analyse ?name) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] - ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] + ["lux;Nil" _]]]]]]] (&&lux/analyse-import analyse ?path) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] + ["lux;Cons" [?type + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]]]] (&&lux/analyse-check analyse eval! exo-type ?type ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]] + ["lux;Cons" [?type + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]]]] (&&lux/analyse-coerce analyse eval! ?type ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] - ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] + ["lux;Nil" _]]]]]]] (&&lux/analyse-export analyse ?ident) [_] @@ -122,53 +122,53 @@ (matchv ::M/objects [token] ;; Host special forms ;; Integer arithmetic - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-iadd analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-isub analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-imul analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-idiv analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-irem analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-ieq analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-ilt analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-igt analyse ?x ?y) ;; Long arithmetic - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-ladd analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-lsub analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-lmul analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-ldiv analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-lrem analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-leq analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-llt analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-lgt analyse ?x ?y) [_] @@ -177,53 +177,53 @@ (defn ^:private aba4 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Float arithmetic - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-fadd analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-fsub analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-fmul analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-fdiv analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-frem analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-feq analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-flt analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-fgt analyse ?x ?y) ;; Double arithmetic - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-dadd analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-dsub analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-dmul analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-ddiv analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-drem analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-deq analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-dlt analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-dgt analyse ?x ?y) [_] @@ -232,101 +232,101 @@ (defn ^:private aba5 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Objects - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] + ["lux;Cons" [?object + ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-null? analyse ?object) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] + ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-new analyse ?class ?classes ?args) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] - ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getstatic"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] + ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-getstatic analyse ?class ?field) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getfield"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] + ["lux;Cons" [?object + ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-getfield analyse ?class ?field ?object) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putstatic"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-putstatic analyse ?class ?field ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] - ["lux;Cons" [?object - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putfield"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] + ["lux;Cons" [?object + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-putfield analyse ?class ?field ?object ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokestatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokestatic"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] + ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-invokestatic analyse ?class ?method ?classes ?args) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokevirtual"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokevirtual"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] + ["lux;Cons" [?object + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] + ["lux;Nil" _]]]]]]]]]]]]]]] (&&host/analyse-jvm-invokevirtual analyse ?class ?method ?classes ?object ?args) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokeinterface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokeinterface"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] + ["lux;Cons" [?object + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] + ["lux;Nil" _]]]]]]]]]]]]]]] (&&host/analyse-jvm-invokeinterface analyse ?class ?method ?classes ?object ?args) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokespecial"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokespecial"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] + ["lux;Cons" [?object + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] + ["lux;Nil" _]]]]]]]]]]]]]]] (&&host/analyse-jvm-invokespecial analyse ?class ?method ?classes ?object ?args) ;; Exceptions - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]] - ["lux;Cons" [?body - ?handlers]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]] + ["lux;Cons" [?body + ?handlers]]]]]] (&&host/analyse-jvm-try analyse ?body (&/fold parse-handler [(list) nil] ?handlers)) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] - ["lux;Cons" [?ex - ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] + ["lux;Cons" [?ex + ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-throw analyse ?ex) ;; Syncronization/monitos - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorenter"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorenter"]]]] + ["lux;Cons" [?monitor + ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-monitorenter analyse ?monitor) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorexit"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorexit"]]]] + ["lux;Cons" [?monitor + ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-monitorexit analyse ?monitor) [_] @@ -335,74 +335,74 @@ (defn ^:private aba6 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Primitive conversions - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-d2f analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-d2i analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-d2l analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-f2d analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-f2i analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-f2l analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-i2b analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-i2c analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-i2d analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-i2f analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-i2l analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-i2s analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-l2d analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-l2f analyse ?value) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-l2i analyse ?value) ;; Bitwise operators - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-iand analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-ior analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-land analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-lor analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-lxor analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-lshl analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-lshr analyse ?x ?y) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-lushr analyse ?x ?y) [_] @@ -411,107 +411,115 @@ (defn ^:private aba7 [analyse eval! exo-type token] (matchv ::M/objects [token] ;; Arrays - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] - ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] + ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-new-array analyse ?class ?length) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Cons" [?elem - ["lux;Nil" _]]]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] + ["lux;Cons" [?array + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] + ["lux;Cons" [?elem + ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] + ["lux;Cons" [?array + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] + ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] - ?methods]]]]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] + ?methods]]]]]]]]]]]] (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] - ?methods]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] + ?methods]]]]]]]] (&&host/analyse-jvm-interface analyse ?name ?supers ?methods) ;; Programs - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?args]]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?args]]]] + ["lux;Cons" [?body + ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-program analyse ?args ?body) [_] (fail ""))) +(defn ^:private add-loc [meta msg] + (if (.startsWith msg "@") + msg + (|let [[file line col] meta] + (str "@ " file " : " line " , " col "\n" msg)))) + (defn ^:private analyse-basic-ast [analyse eval! exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) - (fn [state] - (matchv ::M/objects [((aba1 analyse eval! exo-type token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (matchv ::M/objects [((aba2 analyse eval! exo-type token) state)] + (matchv ::M/objects [token] + [["lux;Meta" [meta ?token]]] + (fn [state] + (matchv ::M/objects [((aba1 analyse eval! exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" ""]] - (matchv ::M/objects [((aba3 analyse eval! exo-type token) state)] + (matchv ::M/objects [((aba2 analyse eval! exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" ""]] - (matchv ::M/objects [((aba4 analyse eval! exo-type token) state)] + (matchv ::M/objects [((aba3 analyse eval! exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" ""]] - (matchv ::M/objects [((aba5 analyse eval! exo-type token) state)] + (matchv ::M/objects [((aba4 analyse eval! exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" ""]] - (matchv ::M/objects [((aba6 analyse eval! exo-type token) state)] + (matchv ::M/objects [((aba5 analyse eval! exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) - + [["lux;Left" ""]] - (matchv ::M/objects [((aba7 analyse eval! exo-type token) state)] + (matchv ::M/objects [((aba6 analyse eval! exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) + + [["lux;Left" ""]] + (matchv ::M/objects [((aba7 analyse eval! exo-type ?token) state)] + [["lux;Right" [state* output]]] + (return* state* output) + + [["lux;Left" msg]] + (fail* (add-loc meta msg))) [["lux;Left" msg]] - (fail* msg)) + (fail* (add-loc meta msg))) [["lux;Left" msg]] - (fail* msg)) + (fail* (add-loc meta msg))) [["lux;Left" msg]] - (fail* msg)) + (fail* (add-loc meta msg))) [["lux;Left" msg]] - (fail* msg)) + (fail* (add-loc meta msg))) [["lux;Left" msg]] - (fail* msg)) + (fail* (add-loc meta msg))) [["lux;Left" msg]] - (fail* msg)) - - [["lux;Left" msg]] - (fail* msg)))) + (fail* (add-loc meta msg)))))) (defn ^:private analyse-ast [eval! exo-type token] (matchv ::M/objects [token] diff --git a/src/lux/reader.clj b/src/lux/reader.clj index fa5d659bf..08b053a85 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -124,11 +124,13 @@ (&/T (&/T file-name line-num column-num*) line))))) (&/V "No" (str "[Reader Error] Text failed: " text)))))) +(def ^:private +source-dir+ "source/") (defn from [file-name file-content] - (let [lines (&/->list (string/split-lines file-content))] + (let [lines (&/->list (string/split-lines file-content)) + file-name (.substring file-name (.length +source-dir+))] (&/|map (fn [line+line-num] (|let [[line-num line] line+line-num] - (&/T (&/T file-name line-num 0) + (&/T (&/T 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 9034abb53..fa598daf1 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -778,7 +778,7 @@ (if (or (.equals ^Object e!name a!name) (.isAssignableFrom (Class/forName e!name) (Class/forName a!name))) (return (&/T fixpoints nil)) - (fail (str "[Type Error] Names don't match: " e!name " & " a!name))) + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))) [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] (|do [[fixpoints* _] (check* fixpoints aI eI)] -- cgit v1.2.3 From c6a120dd8324a306190b593ff1541046e1963e2d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 10 Jun 2015 00:41:02 -0400 Subject: - Reimplemented module-aliasing. --- source/lux.lux | 61 +++++++++++++++++++++---------------- src/lux/analyser/module.clj | 73 ++++++++++++++++++++++++++++++++++----------- src/lux/base.clj | 11 +++---- src/lux/type.clj | 22 ++++++++------ 4 files changed, 108 insertions(+), 59 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 2a4cc8660..10abcb88a 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -244,10 +244,24 @@ #Nil])]))) (_lux_export LuxVar) +## (deftype (Module Compiler) +## (& #aliases (List (, Text Text)) +## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))))) +(_lux_def Module + (#AllT [(#Some #Nil) "lux;Module" "Compiler" + (#RecordT (#Cons [["lux;aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] + (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + SyntaxList])])]) + #Nil])])) + #Nil])]))])] + #Nil])]))])) +(_lux_export Module) + ## (deftype #rec Compiler ## (& #source Reader -## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))))) -## #module-aliases (List Void) +## #modules (List (, Text (Module Compiler))) ## #envs (List (Env Text (, LuxVar Type))) ## #types (Bindings Int Type) ## #host HostState)) @@ -255,21 +269,14 @@ (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [["lux;source" Reader] (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#AppT [(#BoundT "lux;Compiler") - (#BoundT "")])]) - SyntaxList])])]) - #Nil])])) - #Nil])]))]) + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) #Nil])]))])] - (#Cons [["lux;module-aliases" (#AppT [List Void])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - (#Cons [["lux;seed" Int] - #Nil])])])])])])]))]) + (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] + (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] + (#Cons [["lux;host" HostState] + (#Cons [["lux;seed" Int] + #Nil])])])])])]))]) Void])) (_lux_export Compiler) @@ -1293,7 +1300,7 @@ (def'' #export (get-module-name state) ($' Lux Text) (_lux_case state - {#source source #modules modules #module-aliases module-aliases + {#source source #modules modules #envs envs #types types #host host #seed seed} (_lux_case (reverse envs) @@ -1304,12 +1311,13 @@ (#Right [state module-name])))) (def'' (find-macro' modules current-module module name) - (-> ($' List (, Text ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE Compiler ($' List Syntax))))))))) + (-> ($' List (, Text ($' Module Compiler))) Text Text Text ($' Maybe Macro)) (do Maybe:Monad - [bindings (get module modules) - gdef (get name bindings)] + [$module (get module modules) + gdef (let [{#aliases _ #defs bindings} (_lux_: ($' Module Compiler) $module)] + (get name bindings))] (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) [exported? (#MacroD macro')] (if exported? @@ -1331,7 +1339,7 @@ (let [[module name] ident] (lambda [state] (_lux_case state - {#source source #modules modules #module-aliases module-aliases + {#source source #modules modules #envs envs #types types #host host #seed seed} (#Right [state (find-macro' modules current-module module name)])))))) @@ -1741,10 +1749,10 @@ (def #export (gensym prefix state) (-> Text (Lux Syntax)) (case state - {#source source #modules modules #module-aliases module-aliases + {#source source #modules modules #envs envs #types types #host host #seed seed} - (#Right [{#source source #modules modules #module-aliases module-aliases + (#Right [{#source source #modules modules #envs envs #types types #host host #seed (inc seed)} ($symbol ["__gensym__" (int:show seed)])]))) @@ -1950,7 +1958,7 @@ (defmacro #export (lux tokens state) (case state - {#source source #modules modules #module-aliases module-aliases + {#source source #modules modules #envs envs #types types #host host #seed seed} (case (get "lux" modules) @@ -1962,7 +1970,8 @@ (if export? (list name) (list))))) - lux)] + (let [{#aliases _ #defs defs} lux] + defs))] (#Right [state (: (List Syntax) (map (: (-> Text Syntax) (lambda [name] @@ -2044,7 +2053,7 @@ (#Meta [_ (#SymbolS vname)]) (let [vname' (ident->text vname)] (case state - {#source source #modules modules #module-aliases module-aliases + {#source source #modules modules #envs envs #types types #host host #seed seed} (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index f882f1275..cfa39f008 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -6,18 +6,31 @@ [host :as &host]) [lux.analyser.base :as &&])) +;; [Utils] +(def ^:private $ALIASES 0) +(def ^:private $DEFS 1) + ;; [Exports] (def init-module - (&/|table)) + (&/R ;; "lux;aliases" + (&/|table) + ;; "lux;defs" + (&/|table) + )) (defn define [module name def-data type] (fn [state] (matchv ::M/objects [(&/get$ &/$ENVS state)] [["lux;Cons" [?env ["lux;Nil" _]]]] (return* (->> state - (&/update$ &/$MODULES (fn [ms] - (&/|update module #(&/|put name (&/T false def-data) %) - ms))) + (&/update$ &/$MODULES + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $DEFS + #(&/|put name (&/T false def-data) %) + m)) + ms))) (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] (&/update$ &/$MAPPINGS (fn [mappings] (&/|put (str "" &/+name-separator+ name) @@ -35,9 +48,14 @@ (matchv ::M/objects [(&/get$ &/$ENVS state)] [["lux;Cons" [?env ["lux;Nil" _]]]] (return* (->> state - (&/update$ &/$MODULES (fn [ms] - (&/|update a-module #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %) - ms))) + (&/update$ &/$MODULES + (fn [ms] + (&/|update a-module + (fn [m] + (&/update$ $DEFS + #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %) + m)) + ms))) (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] (&/update$ &/$MAPPINGS (fn [mappings] (&/|put (str "" &/+name-separator+ a-name) @@ -55,16 +73,30 @@ (return* state (->> state (&/get$ &/$MODULES) (&/|contains? name))))) -(defn dealias [name] +(defn alias-module [module reference alias] (fn [state] - (if-let [real-name (->> state (&/get$ &/$MODULE-ALIASES) (&/|get name))] - (return* state real-name) - (fail* (str "Unknown alias: " name))))) + (return* (->> state + (&/update$ &/$MODULES + (fn [ms] + (&/|update module + #(&/update$ $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$ $ALIASES) (&/|get name))] + (return* state real-name) + (fail* (str "Unknown alias: " name)))))) (defn find-def [module name] (|do [current-module &/get-module-name] (fn [state] - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] (if-let [$def (&/|get name $module)] (matchv ::M/objects [$def] [[exported? $$def]] @@ -90,7 +122,7 @@ (defn declare-macro [module name] (fn [state] - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] (if-let [$def (&/|get name $module)] (matchv ::M/objects [$def] [[exported? ["lux;ValueD" ?type]]] @@ -102,8 +134,12 @@ (fn [state*] (return* (&/update$ &/$MODULES (fn [$modules] - (&/|put module (&/|put name (&/T exported? (&/V "lux;MacroD" macro)) $module) - $modules)) + (&/|update module + (fn [m] + (&/update$ $DEFS + #(&/|put name (&/T exported? (&/V "lux;MacroD" macro)) %) + m)) + $modules)) state*) nil))) state) @@ -120,7 +156,7 @@ (fn [state] (matchv ::M/objects [(&/get$ &/$ENVS state)] [["lux;Cons" [?env ["lux;Nil" _]]]] - (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/|get name))] + (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))] (matchv ::M/objects [$def] [[true _]] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) @@ -128,7 +164,10 @@ [[false ?data]] (return* (->> state (&/update$ &/$MODULES (fn [ms] - (&/|update module #(&/|put name (&/T true ?data) %) + (&/|update module (fn [m] + (&/update$ $DEFS + #(&/|put name (&/T true ?data) %) + m)) ms)))) nil)) (fail* (str "[Analyser Error] Can't export an inexistent definition: " module ";" name))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 57b25f47e..9087028bb 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -22,11 +22,10 @@ ;; CompilerState (def $ENVS 0) (def $HOST 1) -(def $MODULE-ALIASES 2) -(def $MODULES 3) -(def $SEED 4) -(def $SOURCE 5) -(def $TYPES 6) +(def $MODULES 2) +(def $SEED 3) +(def $SOURCE 4) +(def $TYPES 5) ;; [Exports] (def +name-separator+ ";") @@ -473,8 +472,6 @@ (|list) ;; "lux;host" (host nil) - ;; "lux;module-aliases" - (|table) ;; "lux;modules" (|table) ;; "lux;seed" diff --git a/src/lux/type.clj b/src/lux/type.clj index fa598daf1..d34433f01 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -143,21 +143,25 @@ (&/V "lux;VariantT" (&/|list (&/T "lux;Local" Int) (&/T "lux;Global" Ident)))) +(def $Module + (fAll "lux;$Module" "Compiler" + (&/V "lux;RecordT" + (&/|list (&/T "lux;aliases" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Text))))) + (&/T "lux;defs" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" + (&/|list Text + (&/V "lux;TupleT" (&/|list Bool + (&/V "lux;AppT" (&/T DefData* + (&/V "lux;LambdaT" (&/T SyntaxList + (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;BoundT" "Compiler"))) + SyntaxList))))))))))))))))) + (def $Compiler (&/V "lux;AppT" (&/T (fAll "lux;Compiler" "" (&/V "lux;RecordT" (&/|list (&/T "lux;source" Reader) (&/T "lux;modules" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text - (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" - (&/|list Text - (&/V "lux;TupleT" (&/|list Bool - (&/V "lux;AppT" (&/T DefData* - (&/V "lux;LambdaT" (&/T SyntaxList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Compiler") - (&/V "lux;BoundT" ""))))) - SyntaxList))))))))))))))))) - (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List $Void))) + (&/V "lux;AppT" (&/T $Module (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Compiler") (&/V "lux;BoundT" "")))))))))) (&/T "lux;envs" (&/V "lux;AppT" (&/T List (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Env Text)) (&/V "lux;TupleT" (&/|list LuxVar Type))))))) -- cgit v1.2.3 From 082ef348efef7c4f1941c48f94b58e22fea724a4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 12 Jun 2015 08:04:59 -0400 Subject: - Added imports. - Now storing information about definitions & imports inside the .class files. --- source/lux.lux | 42 ++++++++++++++++++++--------------- src/lux/analyser.clj | 50 +++++++++++++++++++++--------------------- src/lux/analyser/lux.clj | 14 ++++++++++-- src/lux/analyser/module.clj | 53 ++++++++++++++++++++++++++++++++++++++++----- src/lux/base.clj | 7 ++++-- src/lux/compiler.clj | 36 ++++++++++++++++++------------ src/lux/optimizer.clj | 4 ++-- src/lux/reader.clj | 4 ++-- src/lux/type.clj | 8 ++++--- 9 files changed, 145 insertions(+), 73 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 10abcb88a..07b245a5d 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -245,26 +245,31 @@ (_lux_export LuxVar) ## (deftype (Module Compiler) -## (& #aliases (List (, Text Text)) -## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))))) +## (& #module-aliases (List (, Text Text)) +## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) +## #imports (List Text) +## )) (_lux_def Module (#AllT [(#Some #Nil) "lux;Module" "Compiler" - (#RecordT (#Cons [["lux;aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] + (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList (#AppT [(#AppT [StateE (#BoundT "Compiler")]) SyntaxList])])]) #Nil])])) #Nil])]))])] - #Nil])]))])) + (#Cons [["lux;imports" (#AppT [List Text])] + #Nil])])]))])) (_lux_export Module) ## (deftype #rec Compiler -## (& #source Reader -## #modules (List (, Text (Module Compiler))) -## #envs (List (Env Text (, LuxVar Type))) -## #types (Bindings Int Type) -## #host HostState)) +## (& #source Reader +## #modules (List (, Text (Module Compiler))) +## #envs (List (Env Text (, LuxVar Type))) +## #types (Bindings Int Type) +## #host HostState +## #seed Int +## #seen-sources (List Text))) (_lux_def Compiler (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [["lux;source" Reader] @@ -276,7 +281,8 @@ (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] (#Cons [["lux;host" HostState] (#Cons [["lux;seed" Int] - #Nil])])])])])]))]) + (#Cons [["lux;seen-sources" (#AppT [List Text])] + #Nil])])])])])])]))]) Void])) (_lux_export Compiler) @@ -1302,7 +1308,7 @@ (_lux_case state {#source source #modules modules #envs envs #types types #host host - #seed seed} + #seed seed #seen-sources seen-sources} (_lux_case (reverse envs) #Nil (#Left "Can't get the module name without a module!") @@ -1316,7 +1322,7 @@ ($' Maybe Macro)) (do Maybe:Monad [$module (get module modules) - gdef (let [{#aliases _ #defs bindings} (_lux_: ($' Module Compiler) $module)] + gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] (get name bindings))] (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) [exported? (#MacroD macro')] @@ -1341,7 +1347,7 @@ (_lux_case state {#source source #modules modules #envs envs #types types #host host - #seed seed} + #seed seed #seen-sources seen-sources} (#Right [state (find-macro' modules current-module module name)])))))) (def'' (list:join xs) @@ -1751,10 +1757,10 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed} + #seed seed #seen-sources seen-sources} (#Right [{#source source #modules modules #envs envs #types types #host host - #seed (inc seed)} + #seed (inc seed) #seen-sources seen-sources} ($symbol ["__gensym__" (int:show seed)])]))) (def #export (macro-expand-1 token) @@ -1960,7 +1966,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed} + #seed seed #seen-sources seen-sources} (case (get "lux" modules) (#Some lux) (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) @@ -1970,7 +1976,7 @@ (if export? (list name) (list))))) - (let [{#aliases _ #defs defs} lux] + (let [{#module-aliases _ #defs defs #imports _} lux] defs))] (#Right [state (: (List Syntax) (map (: (-> Text Syntax) @@ -2055,7 +2061,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed} + #seed seed #seen-sources seen-sources} (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) (lambda [env] (case env diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index a89d37ee5..4cb1a4900 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -27,7 +27,7 @@ (&/T catch+ ?finally-body))) (let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (|list))))] - (defn ^:private aba1 [analyse eval! exo-type token] + (defn ^:private aba1 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] ;; Standard special forms [["lux;BoolS" ?value]] @@ -66,7 +66,7 @@ (fail "") ))) -(defn ^:private aba2 [analyse eval! exo-type token] +(defn ^:private aba2 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] [["lux;SymbolS" ?ident]] (&&lux/analyse-symbol analyse exo-type ?ident) @@ -96,7 +96,7 @@ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] ["lux;Nil" _]]]]]]] - (&&lux/analyse-import analyse ?path) + (&&lux/analyse-import analyse compile-module ?path) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] ["lux;Cons" [?type @@ -118,7 +118,7 @@ [_] (fail ""))) -(defn ^:private aba3 [analyse eval! exo-type token] +(defn ^:private aba3 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] ;; Host special forms ;; Integer arithmetic @@ -174,7 +174,7 @@ [_] (fail ""))) -(defn ^:private aba4 [analyse eval! exo-type token] +(defn ^:private aba4 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] ;; Float arithmetic [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] @@ -229,7 +229,7 @@ [_] (fail ""))) -(defn ^:private aba5 [analyse eval! exo-type token] +(defn ^:private aba5 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] ;; Objects [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] @@ -332,7 +332,7 @@ [_] (fail ""))) -(defn ^:private aba6 [analyse eval! exo-type token] +(defn ^:private aba6 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] ;; Primitive conversions [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] @@ -408,7 +408,7 @@ [_] (fail ""))) -(defn ^:private aba7 [analyse eval! exo-type token] +(defn ^:private aba7 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] ;; Arrays [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] @@ -455,48 +455,48 @@ [_] (fail ""))) -(defn ^:private add-loc [meta msg] +(defn ^:private add-loc [meta ^String msg] (if (.startsWith msg "@") msg (|let [[file line col] meta] (str "@ " file " : " line " , " col "\n" msg)))) -(defn ^:private analyse-basic-ast [analyse eval! exo-type token] +(defn ^:private analyse-basic-ast [analyse eval! compile-module exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (matchv ::M/objects [token] [["lux;Meta" [meta ?token]]] (fn [state] - (matchv ::M/objects [((aba1 analyse eval! exo-type ?token) state)] + (matchv ::M/objects [((aba1 analyse eval! compile-module exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" ""]] - (matchv ::M/objects [((aba2 analyse eval! exo-type ?token) state)] + (matchv ::M/objects [((aba2 analyse eval! compile-module exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" ""]] - (matchv ::M/objects [((aba3 analyse eval! exo-type ?token) state)] + (matchv ::M/objects [((aba3 analyse eval! compile-module exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" ""]] - (matchv ::M/objects [((aba4 analyse eval! exo-type ?token) state)] + (matchv ::M/objects [((aba4 analyse eval! compile-module exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" ""]] - (matchv ::M/objects [((aba5 analyse eval! exo-type ?token) state)] + (matchv ::M/objects [((aba5 analyse eval! compile-module exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" ""]] - (matchv ::M/objects [((aba6 analyse eval! exo-type ?token) state)] + (matchv ::M/objects [((aba6 analyse eval! compile-module exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" ""]] - (matchv ::M/objects [((aba7 analyse eval! exo-type ?token) state)] + (matchv ::M/objects [((aba7 analyse eval! compile-module exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) @@ -521,25 +521,25 @@ [["lux;Left" msg]] (fail* (add-loc meta msg)))))) -(defn ^:private analyse-ast [eval! exo-type token] +(defn ^:private analyse-ast [eval! compile-module exo-type token] (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] (do (assert (.equals ^Object (&/|length ?values) 1) "[Analyser Error] Can only tag 1 value.") - (&&lux/analyse-variant (partial analyse-ast eval!) exo-type ?ident (&/|head ?values))) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module) exo-type ?ident (&/|head ?values))) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] (fn [state] - (matchv ::M/objects [((&type/with-var #(&&/analyse-1 (partial analyse-ast eval!) % ?fn)) state)] + (matchv ::M/objects [((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state)] [["lux;Right" [state* =fn]]] - ((&&lux/analyse-apply (partial analyse-ast eval!) exo-type =fn ?args) state*) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type =fn ?args) state*) [_] - ((analyse-basic-ast (partial analyse-ast eval!) eval! exo-type token) state))) + ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) [_] - (analyse-basic-ast (partial analyse-ast eval!) eval! exo-type token))) + (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token))) ;; [Resources] -(defn analyse [eval!] +(defn analyse [eval! compile-module] (|do [asts &parser/parse] - (&/flat-map% (partial analyse-ast eval! &type/$Void) asts))) + (&/flat-map% (partial analyse-ast eval! compile-module &type/$Void) asts))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index cdecd234f..242539b65 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -316,8 +316,18 @@ (|do [module-name &/get-module-name] (return (&/|list (&/V "declare-macro" (&/T module-name ?name)))))) -(defn analyse-import [analyse exo-type ?path] - (return (&/|list))) +(defn analyse-import [analyse compile-module ?path] + (prn 'analyse-import ?path) + (fn [state] + (let [already-compiled? (&/fold false #(or %1 (= %2 ?path)) (&/get$ &/$SEEN-SOURCES state))] + (&/run-state (|do [_ (&&module/add-import ?path) + _ (if already-compiled? + (return nil) + (compile-module ?path))] + (return (&/|list))) + (if already-compiled? + state + (&/update$ &/$SEEN-SOURCES (partial &/|cons ?path) state)))))) (defn analyse-export [analyse name] (|do [module-name &/get-module-name diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index cfa39f008..1fd96ce0a 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -1,23 +1,38 @@ (ns lux.analyser.module (:require [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail*]] + (lux [base :as & :refer [|let |do return return* fail fail*]] [type :as &type] [host :as &host]) [lux.analyser.base :as &&])) ;; [Utils] -(def ^:private $ALIASES 0) -(def ^:private $DEFS 1) +(def ^:private $DEFS 0) +(def ^:private $ALIASES 1) +(def ^:private $IMPORTS 2) ;; [Exports] (def init-module - (&/R ;; "lux;aliases" + (&/R ;; "lux;defs" (&/|table) - ;; "lux;defs" + ;; "lux;module-aliases" (&/|table) + ;; "lux;imports" + (&/|list) )) +(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) + nil)))) + (defn define [module name def-data type] (fn [state] (matchv ::M/objects [(&/get$ &/$ENVS state)] @@ -69,6 +84,7 @@ (fail* "[Analyser Error] Can't alias a global definition outside of a global environment.")))) (defn exists? [name] + "(-> Text (Lux Bool))" (fn [state] (return* state (->> state (&/get$ &/$MODULES) (&/|contains? name))))) @@ -174,3 +190,30 @@ [_] (fail* "[Analyser Error] Can't export a global definition outside of a global environment.")))) + +(def defs + (|do [module &/get-module-name] + (fn [state] + (return* state + (&/|map (fn [kv] + (|let [[k v] kv] + (matchv ::M/objects [v] + [[?exported? ?def]] + (matchv ::M/objects [?def] + [["lux;AliasD" [?r-module ?r-name]]] + (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) + + [["lux;MacroD" _]] + (&/T ?exported? k "M") + + [["lux;TypeD" _]] + (&/T ?exported? k "T") + + [_] + (&/T ?exported? k "V"))))) + (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))))))) + +(def imports + (|do [module &/get-module-name] + (fn [state] + (return* state (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $IMPORTS)))))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 9087028bb..657ebd51e 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -24,8 +24,9 @@ (def $HOST 1) (def $MODULES 2) (def $SEED 3) -(def $SOURCE 4) -(def $TYPES 5) +(def $SEEN-SOURCES 4) +(def $SOURCE 5) +(def $TYPES 6) ;; [Exports] (def +name-separator+ ";") @@ -476,6 +477,8 @@ (|table) ;; "lux;seed" 0 + ;; "lux;seen-sources" + (|list) ;; "lux;source" (V "lux;None" nil) ;; "lux;types" diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index a0425cdbe..90a382ed5 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -5,7 +5,7 @@ [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [|let |do return* return fail fail*]] [type :as &type] [reader :as &reader] [lexer :as &lexer] @@ -347,9 +347,9 @@ (.get nil) return))) -(let [compiler-step (|do [analysis+ (&optimizer/optimize eval!)] - (&/map% compile-statement analysis+))] - (defn ^:private compile-module [name] +(defn ^:private compile-module [name] + (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] + (&/map% compile-statement analysis+))] (fn [state] (if (->> state (&/get$ &/$MODULES) (&/|contains? name)) (if (.equals ^Object name "lux") @@ -363,14 +363,7 @@ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil (hash file-content)) .visitEnd) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil version) - .visitEnd) - ;; (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil ...) - ;; .visitEnd) - ;; (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_exports" "Ljava/lang/String;" nil ...) - ;; .visitEnd) - ;; (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_macros" "Ljava/lang/String;" nil ...) - ;; .visitEnd) - )] + .visitEnd))] (matchv ::M/objects [((&/exhaust% compiler-step) (->> state (&/set$ &/$SOURCE (&reader/from file-name file-content)) @@ -378,8 +371,23 @@ (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %)) (&/update$ &/$MODULES #(&/|put name &a-module/init-module %))))] [["lux;Right" [?state _]]] - (do (.visitEnd =class) - ((&&/save-class! name (.toByteArray =class)) ?state)) + (&/run-state (|do [defs &a-module/defs + imports &a-module/imports + :let [_ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil + (->> defs + (&/|map (fn [_def] + (|let [[?exported ?name ?ann] _def] + (str (if ?exported "1" "0") " " ?name " " ?ann)))) + (&/|interpose "\t") + (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil + (->> imports (&/|interpose ";") (&/fold str ""))) + .visitEnd) + (.visitEnd))]] + (&&/save-class! name (.toByteArray =class))) + ?state) [["lux;Left" ?message]] (fail* ?message))))))) diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index e50d2aae9..8b97b6ebb 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -15,5 +15,5 @@ ;; Global var aliasing. ;; [Exports] -(defn optimize [eval!] - (&analyser/analyse eval!)) +(defn optimize [eval! compile-module] + (&analyser/analyse eval! compile-module)) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 08b053a85..0e8c1b710 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -124,8 +124,8 @@ (&/T (&/T file-name line-num column-num*) line))))) (&/V "No" (str "[Reader Error] Text failed: " text)))))) -(def ^:private +source-dir+ "source/") -(defn from [file-name file-content] +(def ^:private ^String +source-dir+ "source/") +(defn from [^String file-name ^String file-content] (let [lines (&/->list (string/split-lines file-content)) file-name (.substring file-name (.length +source-dir+))] (&/|map (fn [line+line-num] diff --git a/src/lux/type.clj b/src/lux/type.clj index d34433f01..d82eae8fd 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -146,14 +146,15 @@ (def $Module (fAll "lux;$Module" "Compiler" (&/V "lux;RecordT" - (&/|list (&/T "lux;aliases" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Text))))) + (&/|list (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Text))))) (&/T "lux;defs" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text (&/V "lux;TupleT" (&/|list Bool (&/V "lux;AppT" (&/T DefData* (&/V "lux;LambdaT" (&/T SyntaxList (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;BoundT" "Compiler"))) - SyntaxList))))))))))))))))) + SyntaxList))))))))))))) + (&/T "lux;imports" (&/V "lux;AppT" (&/T List Text))))))) (def $Compiler (&/V "lux;AppT" (&/T (fAll "lux;Compiler" "" @@ -167,7 +168,8 @@ (&/V "lux;TupleT" (&/|list LuxVar Type))))))) (&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type))) (&/T "lux;host" HostState) - (&/T "lux;seed" Int)))) + (&/T "lux;seed" Int) + (&/T "lux;seen-sources" (&/V "lux;AppT" (&/T List Text)))))) $Void))) (def Macro -- cgit v1.2.3 From 5e9e876131901204dd34ce1548a4df3cb6cba95f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 20 Jun 2015 20:19:02 -0400 Subject: - The directory for source-code is now named "input". - Implemented module-caching to avoid the waiting too much during program compilation. --- input/lux.lux | 2173 +++++++++++++++++++++++++++++++++++++++++++ input/program.lux | 15 + source/lux.lux | 2169 ------------------------------------------ source/program.lux | 15 - src/lux/analyser.clj | 10 +- src/lux/analyser/host.clj | 2 +- src/lux/analyser/lux.clj | 128 +-- src/lux/analyser/module.clj | 82 +- src/lux/base.clj | 37 +- src/lux/compiler.clj | 165 ++-- src/lux/compiler/base.clj | 184 +++- src/lux/compiler/host.clj | 76 +- src/lux/compiler/lambda.clj | 5 +- src/lux/compiler/lux.clj | 12 +- src/lux/reader.clj | 2 +- src/lux/type.clj | 3 +- 16 files changed, 2654 insertions(+), 2424 deletions(-) create mode 100644 input/lux.lux create mode 100644 input/program.lux delete mode 100644 source/lux.lux delete mode 100644 source/program.lux diff --git a/input/lux.lux b/input/lux.lux new file mode 100644 index 000000000..6c9a50f9d --- /dev/null +++ b/input/lux.lux @@ -0,0 +1,2173 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +## First things first, must define functions +(_jvm_interface "Function" [] + (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## ( [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) + +## Basic types +(_lux_def Bool (#DataT "java.lang.Boolean")) +(_lux_export Bool) + +(_lux_def Int (#DataT "java.lang.Long")) +(_lux_export Int) + +(_lux_def Real (#DataT "java.lang.Double")) +(_lux_export Real) + +(_lux_def Char (#DataT "java.lang.Character")) +(_lux_export Char) + +(_lux_def Text (#DataT "java.lang.String")) +(_lux_export Text) + +(_lux_def Void (#VariantT #Nil)) +(_lux_export Void) + +(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) +(_lux_export Ident) + +## (deftype (List a) +## (| #Nil +## (#Cons (, a (List a))))) +(_lux_def List + (#AllT [(#Some #Nil) "lux;List" "a" + (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] + (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") + (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) + #Nil])]))] + #Nil])]))])) +(_lux_export List) + +## (deftype (Maybe a) +## (| #None +## (#Some a))) +(_lux_def Maybe + (#AllT [(#Some #Nil) "lux;Maybe" "a" + (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] + (#Cons [["lux;Some" (#BoundT "a")] + #Nil])]))])) +(_lux_export Maybe) + +## (deftype #rec Type +## (| (#DataT Text) +## (#TupleT (List Type)) +## (#VariantT (List (, Text Type))) +## (#RecordT (List (, Text Type))) +## (#LambdaT (, Type Type)) +## (#BoundT Text) +## (#VarT Int) +## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) +## (#AppT (, Type Type)))) +(_lux_def Type + (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) + Type + (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) + TypeEnv + (#AppT [(#AllT [(#Some #Nil) "Type" "_" + (#VariantT (#Cons [["lux;DataT" Text] + (#Cons [["lux;TupleT" (#AppT [List Type])] + (#Cons [["lux;VariantT" TypeEnv] + (#Cons [["lux;RecordT" TypeEnv] + (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;BoundT" Text] + (#Cons [["lux;VarT" Int] + (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] + (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;ExT" Int] + #Nil])])])])])])])])])]))]) + Void])))) +(_lux_export Type) + +## (deftype (Bindings k v) +## (& #counter Int +## #mappings (List (, k v)))) +(_lux_def Bindings + (#AllT [(#Some #Nil) "lux;Bindings" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;counter" Int] + (#Cons [["lux;mappings" (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))])] + #Nil])]))])])) + +## (deftype (Env k v) +## (& #name Text +## #inner-closures Int +## #locals (Bindings k v) +## #closure (Bindings k v))) +(_lux_def Env + (#AllT [(#Some #Nil) "lux;Env" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;name" Text] + (#Cons [["lux;inner-closures" Int] + (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + #Nil])])])]))])])) + +## (deftype Cursor +## (, Text Int Int)) +(_lux_def Cursor + (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) + +## (deftype (Meta m v) +## (| (#Meta (, m v)))) +(_lux_def Meta + (#AllT [(#Some #Nil) "lux;Meta" "m" + (#AllT [#None "" "v" + (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") + (#Cons [(#BoundT "v") + #Nil])]))] + #Nil]))])])) +(_lux_export Meta) + +## (deftype (Syntax' w) +## (| (#BoolS Bool) +## (#IntS Int) +## (#RealS Real) +## (#CharS Char) +## (#TextS Text) +## (#SymbolS (, Text Text)) +## (#TagS (, Text Text)) +## (#FormS (List (w (Syntax' w)))) +## (#TupleS (List (w (Syntax' w)))) +## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) +(_lux_def Syntax' + (_lux_case (#AppT [(#BoundT "w") + (#AppT [(#BoundT "lux;Syntax'") + (#BoundT "w")])]) + Syntax + (_lux_case (#AppT [List Syntax]) + SyntaxList + (#AllT [(#Some #Nil) "lux;Syntax'" "w" + (#VariantT (#Cons [["lux;BoolS" Bool] + (#Cons [["lux;IntS" Int] + (#Cons [["lux;RealS" Real] + (#Cons [["lux;CharS" Char] + (#Cons [["lux;TextS" Text] + (#Cons [["lux;SymbolS" Ident] + (#Cons [["lux;TagS" Ident] + (#Cons [["lux;FormS" SyntaxList] + (#Cons [["lux;TupleS" SyntaxList] + (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] + #Nil]) + ])])])])])])])])]) + )])))) +(_lux_export Syntax') + +## (deftype Syntax +## (Meta Cursor (Syntax' (Meta Cursor)))) +(_lux_def Syntax + (_lux_case (#AppT [Meta Cursor]) + w + (#AppT [w (#AppT [Syntax' w])]))) +(_lux_export Syntax) + +(_lux_def SyntaxList (#AppT [List Syntax])) + +## (deftype (Either l r) +## (| (#Left l) +## (#Right r))) +(_lux_def Either + (#AllT [(#Some #Nil) "lux;Either" "l" + (#AllT [#None "" "r" + (#VariantT (#Cons [["lux;Left" (#BoundT "l")] + (#Cons [["lux;Right" (#BoundT "r")] + #Nil])]))])])) +(_lux_export Either) + +## (deftype (StateE s a) +## (-> s (Either Text (, s a)))) +(_lux_def StateE + (#AllT [(#Some #Nil) "lux;StateE" "s" + (#AllT [#None "" "a" + (#LambdaT [(#BoundT "s") + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [(#BoundT "s") + (#Cons [(#BoundT "a") + #Nil])]))])])])])) + +## (deftype Reader +## (List (Meta Cursor Text))) +(_lux_def Reader + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])])) +(_lux_export Reader) + +## (deftype HostState +## (& #writer (^ org.objectweb.asm.ClassWriter) +## #loader (^ java.net.URLClassLoader) +## #classes (^ clojure.lang.Atom))) +(_lux_def HostState + (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] + (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] + (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] + #Nil])])]))) + +## (deftype (DefData' m) +## (| #TypeD +## (#ValueD Type) +## (#MacroD m) +## (#AliasD Ident))) +(_lux_def DefData' + (#AllT [(#Some #Nil) "lux;DefData'" "" + (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] + (#Cons [["lux;ValueD" Type] + (#Cons [["lux;MacroD" (#BoundT "")] + (#Cons [["lux;AliasD" Ident] + #Nil])])])]))])) + +## (deftype LuxVar +## (| (#Local Int) +## (#Global Ident))) +(_lux_def LuxVar + (#VariantT (#Cons [["lux;Local" Int] + (#Cons [["lux;Global" Ident] + #Nil])]))) +(_lux_export LuxVar) + +## (deftype (Module Compiler) +## (& #module-aliases (List (, Text Text)) +## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) +## #imports (List Text) +## )) +(_lux_def Module + (#AllT [(#Some #Nil) "lux;Module" "Compiler" + (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] + (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + SyntaxList])])]) + #Nil])])) + #Nil])]))])] + (#Cons [["lux;imports" (#AppT [List Text])] + #Nil])])]))])) +(_lux_export Module) + +## (deftype #rec Compiler +## (& #source Reader +## #modules (List (, Text (Module Compiler))) +## #envs (List (Env Text (, LuxVar Type))) +## #types (Bindings Int Type) +## #host HostState +## #seed Int +## #seen-sources (List Text) +## #eval? Bool)) +(_lux_def Compiler + (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" + (#RecordT (#Cons [["lux;source" Reader] + (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) + #Nil])]))])] + (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] + (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] + (#Cons [["lux;host" HostState] + (#Cons [["lux;seed" Int] + (#Cons [["lux;seen-sources" (#AppT [List Text])] + (#Cons [["lux;eval?" Bool] + #Nil])])])])])])])]))]) + Void])) +(_lux_export Compiler) + +## (deftype Macro +## (-> (List Syntax) (StateE Compiler (List Syntax)))) +(_lux_def Macro + (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE Compiler]) + SyntaxList])])) +(_lux_export Macro) + +## Base functions & macros +## (def (_meta data) +## (-> (Syntax' (Meta Cursor)) Syntax) +## (#Meta [["" -1 -1] data])) +(_lux_def _meta + (_lux_: (#LambdaT [(#AppT [Syntax' + (#AppT [Meta Cursor])]) + Syntax]) + (_lux_lambda _ data + (#Meta [["" -1 -1] data])))) + +## (def (return x) +## (All [a] +## (-> a Compiler +## (Either Text (, Compiler a)))) +## ...) +(_lux_def return + (_lux_: (#AllT [(#Some #Nil) "" "a" + (#LambdaT [(#BoundT "a") + (#LambdaT [Compiler + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [Compiler + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ val + (_lux_lambda _ state + (#Right [state val]))))) + +## (def (fail msg) +## (All [a] +## (-> Text Compiler +## (Either Text (, Compiler a)))) +## ...) +(_lux_def fail + (_lux_: (#AllT [(#Some #Nil) "" "a" + (#LambdaT [Text + (#LambdaT [Compiler + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [Compiler + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ msg + (_lux_lambda _ state + (#Left msg))))) + +(_lux_def $text + (_lux_: (#LambdaT [Text Syntax]) + (_lux_lambda _ text + (_meta (#TextS text))))) + +(_lux_def $symbol + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#SymbolS ident))))) + +(_lux_def $tag + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#TagS ident))))) + +(_lux_def $form + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#FormS tokens))))) + +(_lux_def $tuple + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#TupleS tokens))))) + +(_lux_def $record + (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_lambda _ tokens + (_meta (#RecordS tokens))))) + +(_lux_def let' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) + (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + #Nil]))) + + _ + (fail "Wrong syntax for let'"))))) +(_lux_declare-macro let') + +(_lux_def lambda' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS ["" ""])) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil]))) + + (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS self)) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil]))) + + _ + (fail "Wrong syntax for lambda"))))) +(_lux_declare-macro lambda') + +(_lux_def def' + (_lux_: Macro + (lambda' [tokens] + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])]))) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])]))) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + #Nil]))) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + #Nil]))) + + _ + (fail "Wrong syntax for def") + )))) +(_lux_declare-macro def') + +(def' #export (defmacro tokens) + Macro + (_lux_case tokens + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#Cons [($form (#Cons [($symbol ["lux" "def'"]) + (#Cons [($form (#Cons [name args])) + (#Cons [($symbol ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])) + (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])]))) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (#Cons [($form (#Cons [($symbol ["lux" "def'"]) + (#Cons [($tag ["" "export"]) + (#Cons [($form (#Cons [name args])) + (#Cons [($symbol ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])])) + (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])]))) + + _ + (fail "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) + +(defmacro #export (comment tokens) + (return (_lux_: SyntaxList #Nil))) + +(defmacro (->' tokens) + (_lux_case tokens + (#Cons [input (#Cons [output #Nil])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil]))) + + (#Cons [input (#Cons [output others])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) + #Nil]))) + + _ + (fail "Wrong syntax for ->'"))) + +(defmacro (All' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS #Nil)]) + (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#Cons [body + #Nil]))) + + (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) + (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) + (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) + (#Cons [(_meta (#TextS "")) + (#Cons [(_meta (#TextS arg-name)) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) + (#Cons [(_meta (#TupleS other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) + #Nil]))) + + _ + (fail "Wrong syntax for All'"))) + +(defmacro (B' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) + #Nil]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) + (#Cons [(_meta (#TextS bound-name)) + #Nil])]))) + #Nil]))) + + _ + (fail "Wrong syntax for B'"))) + +(defmacro ($' tokens) + (_lux_case tokens + (#Cons [x #Nil]) + (return tokens) + + (#Cons [x (#Cons [y xs])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) + (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) + #Nil]))) + + _ + (fail "Wrong syntax for $'"))) + +(def' #export (foldL f init xs) + (All' [a b] + (->' (->' (B' a) (B' b) (B' a)) + (B' a) + ($' List (B' b)) + (B' a))) + (_lux_case xs + #Nil + init + + (#Cons [x xs']) + (foldL f (f init x) xs'))) + +(def' #export (foldR f init xs) + (All' [a b] + (->' (->' (B' b) (B' a) (B' a)) + (B' a) + ($' List (B' b)) + (B' a))) + (_lux_case xs + #Nil + init + + (#Cons [x xs']) + (f x (foldR f init xs')))) + +(def' #export (reverse list) + (All' [a] + (->' ($' List (B' a)) ($' List (B' a)))) + (foldL (_lux_: (All' [a] + (->' ($' List (B' a)) (B' a) ($' List (B' a)))) + (lambda' [tail head] + (#Cons [head tail]))) + #Nil + list)) + +(defmacro #export (list xs) + (return (_lux_: SyntaxList + (#Cons [(foldL (lambda' [tail head] + (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) + (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) + (_meta (#TagS ["lux" "Nil"])) + (reverse xs)) + #Nil])))) + +(defmacro #export (list& xs) + (_lux_case (reverse xs) + (#Cons [last init]) + (return (_lux_: SyntaxList + (list (foldL (lambda' [tail head] + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) + last + init)))) + + _ + (fail "Wrong syntax for list&"))) + +(defmacro #export (lambda tokens) + (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) + [name tokens'] + + _ + [["" ""] tokens])) + (_lux_case tokens' + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case args + #Nil + (fail "lambda requires a non-empty arguments tuple.") + + (#Cons [harg targs]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_lambda"]) + ($symbol name) + harg + (foldL (lambda' [body' arg] + ($form (list ($symbol ["" "_lux_lambda"]) + ($symbol ["" ""]) + arg + body'))) + body + (reverse targs)))))))) + + _ + (fail "Wrong syntax for lambda")))) + +(defmacro (def'' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))) + ($form (list ($symbol ["" "_lux_export"]) name))))) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + body)))) + ($form (list ($symbol ["" "_lux_export"]) name))))) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body))))))))) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (_lux_: SyntaxList + (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) type body))))))) + + _ + (fail "Wrong syntax for def") + )) + +(def'' (as-pairs xs) + (All' [a] + (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) + (_lux_case xs + (#Cons [x (#Cons [y xs'])]) + (#Cons [[x y] (as-pairs xs')]) + + _ + #Nil)) + +(defmacro #export (let tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (_lux_case binding + [label value] + (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) + body + (foldL (_lux_: (All' [a] + (->' ($' List (B' a)) (B' a) ($' List (B' a)))) + (lambda [tail head] (#Cons [head tail]))) + #Nil + (as-pairs bindings)))))) + + _ + (fail "Wrong syntax for let"))) + +(def'' #export (map f xs) + (All' [a b] + (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) + (_lux_case xs + #Nil + #Nil + + (#Cons [x xs']) + (#Cons [(f x) (map f xs')]))) + +(def'' #export (any? p xs) + (All' [a] + (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) + (_lux_case xs + #Nil + false + + (#Cons [x xs']) + (_lux_case (p x) + true true + false (any? p xs')))) + +(def'' (spliced? token) + (->' Syntax Bool) + (_lux_case token + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) + true + + _ + false)) + +(def'' (wrap-meta content) + (->' Syntax Syntax) + (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) + (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) + content))))))) + +(def'' (untemplate-list tokens) + (->' ($' List Syntax) Syntax) + (_lux_case tokens + #Nil + (_meta (#TagS ["lux" "Nil"])) + + (#Cons [token tokens']) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list token (untemplate-list tokens'))))))))) + +(def'' (list:++ xs ys) + (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) + (_lux_case xs + (#Cons [x xs']) + (#Cons [x (list:++ xs' ys)]) + + #Nil + ys)) + +(defmacro #export ($ tokens) + (_lux_case tokens + (#Cons [op (#Cons [init args])]) + (return (_lux_: SyntaxList + (list (foldL (lambda [a1 a2] ($form (list op a1 a2))) + init + args)))) + + _ + (fail "Wrong syntax for $"))) + +(def'' (splice untemplate tag elems) + (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) + (_lux_case (any? spliced? elems) + true + (let [elems' (map (_lux_: (->' Syntax Syntax) + (lambda [elem] + (_lux_case elem + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced + + _ + ($form (list ($symbol ["" "_lux_:"]) + ($symbol ["lux" "SyntaxList"]) + ($form (list ($symbol ["lux" "list"]) (untemplate elem)))))))) + elems)] + (wrap-meta ($form (list tag + ($form (list& ($symbol ["lux" "$"]) + ($symbol ["lux" "list:++"]) + elems')))))) + + false + (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) + +(def'' (untemplate subst token) + (->' Text Syntax Syntax) + (_lux_case token + (#Meta [_ (#BoolS value)]) + (wrap-meta ($form (list ($tag ["lux" "BoolS"]) (_meta (#BoolS value))))) + + (#Meta [_ (#IntS value)]) + (wrap-meta ($form (list ($tag ["lux" "IntS"]) (_meta (#IntS value))))) + + (#Meta [_ (#RealS value)]) + (wrap-meta ($form (list ($tag ["lux" "RealS"]) (_meta (#RealS value))))) + + (#Meta [_ (#CharS value)]) + (wrap-meta ($form (list ($tag ["lux" "CharS"]) (_meta (#CharS value))))) + + (#Meta [_ (#TextS value)]) + (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value))))) + + (#Meta [_ (#TagS [module name])]) + (let [module' (_lux_case module + "" + subst + + _ + module)] + (wrap-meta ($form (list ($tag ["lux" "TagS"]) ($tuple (list ($text module') ($text name))))))) + + (#Meta [_ (#SymbolS [module name])]) + (let [module' (_lux_case module + "" + subst + + _ + module)] + (wrap-meta ($form (list ($tag ["lux" "SymbolS"]) ($tuple (list ($text module') ($text name))))))) + + (#Meta [_ (#TupleS elems)]) + (splice (untemplate subst) ($tag ["lux" "TupleS"]) elems) + + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))]) + unquoted + + (#Meta [_ (#FormS elems)]) + (splice (untemplate subst) ($tag ["lux" "FormS"]) elems) + + (#Meta [_ (#RecordS fields)]) + (wrap-meta ($form (list ($tag ["lux" "RecordS"]) + (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) + (lambda [kv] + (let [[k v] kv] + ($tuple (list (untemplate subst k) (untemplate subst v)))))) + fields))))) + )) + +(defmacro (`' tokens) + (_lux_case tokens + (#Cons [template #Nil]) + (return (_lux_: SyntaxList + (list (untemplate "" template)))) + + _ + (fail "Wrong syntax for `'"))) + +(defmacro #export (|> tokens) + (_lux_case tokens + (#Cons [init apps]) + (return (_lux_: SyntaxList + (list (foldL (_lux_: (->' Syntax Syntax Syntax) + (lambda [acc app] + (_lux_case app + (#Meta [_ (#FormS parts)]) + ($form (list:++ parts (list acc))) + + _ + (`' ((~ app) (~ acc)))))) + init + apps)))) + + _ + (fail "Wrong syntax for |>"))) + +(defmacro #export (if tokens) + (_lux_case tokens + (#Cons [test (#Cons [then (#Cons [else #Nil])])]) + (return (_lux_: SyntaxList + (list (`' (_lux_case (~ test) + true (~ then) + false (~ else)))))) + + _ + (fail "Wrong syntax for if"))) + +## (deftype (Lux a) +## (-> Compiler (Either Text (, Compiler a)))) +(def'' #export Lux + Type + (All' [a] + (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) + +## (defsig (Monad m) +## (: (All [a] (-> a (m a))) +## return) +## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) +## bind)) +(def'' Monad + Type + (All' [m] + (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] + ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b))))])))) + +(def'' Maybe:Monad + ($' Monad Maybe) + {#lux;return + (lambda return [x] + (#Some x)) + + #lux;bind + (lambda [f ma] + (_lux_case ma + #None #None + (#Some a) (f a)))}) + +(def'' Lux:Monad + ($' Monad Lux) + {#lux;return + (lambda [x] + (lambda [state] + (#Right [state x]))) + + #lux;bind + (lambda [f ma] + (lambda [state] + (_lux_case (ma state) + (#Left msg) + (#Left msg) + + (#Right [state' a]) + (f a state'))))}) + +(defmacro #export (^ tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) + (return (_lux_: SyntaxList + (list (`' (#;DataT (~ (_meta (#TextS class-name)))))))) + + _ + (fail "Wrong syntax for ^"))) + +(defmacro #export (-> tokens) + (_lux_case (reverse tokens) + (#Cons [output inputs]) + (return (_lux_: SyntaxList + (list (foldL (_lux_: (->' Syntax Syntax Syntax) + (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))) + output + inputs)))) + + _ + (fail "Wrong syntax for ->"))) + +(defmacro #export (, tokens) + (return (_lux_: SyntaxList + (list (`' (#;TupleT (;list (~@ tokens)))))))) + +(defmacro (do tokens) + (_lux_case tokens + (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) + (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (_lux_case var + (#Meta [_ (#TagS ["" "let"])]) + (`' (;let (~ value) (~ body'))) + + _ + (`' (;bind (_lux_lambda (~ ($symbol ["" ""])) + (~ var) + (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (return (_lux_: SyntaxList + (list (`' (_lux_case (~ monad) + {#;return ;return #;bind ;bind} + (~ body'))))))) + + _ + (fail "Wrong syntax for do"))) + +(def'' (map% m f xs) + ## (All [m a b] + ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (All' [m a b] + (-> ($' Monad (B' m)) + (-> (B' a) ($' (B' m) (B' b))) + ($' List (B' a)) + ($' (B' m) ($' List (B' b))))) + (let [{#;return ;return #;bind _} m] + (_lux_case xs + #Nil + (;return (_lux_: List #Nil)) + + (#Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;return (_lux_: List (#Cons [y ys])))) + ))) + +(def'' #export (. f g) + (All' [a b c] + (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) + (lambda [x] + (f (g x)))) + +(def'' (get-ident x) + (-> Syntax ($' Maybe Text)) + (_lux_case x + (#Meta [_ (#SymbolS ["" sname])]) + (#Some sname) + + _ + #None)) + +(def'' (tuple->list tuple) + (-> Syntax ($' Maybe ($' List Syntax))) + (_lux_case tuple + (#Meta [_ (#TupleS members)]) + (#Some members) + + _ + #None)) + +(def'' RepEnv + Type + ($' List (, Text Syntax))) + +(def'' (make-env xs ys) + (-> ($' List Text) ($' List Syntax) RepEnv) + (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) + [xs ys]) + [(#Cons [x xs']) (#Cons [y ys'])] + (#Cons [[x y] (make-env xs' ys')]) + + _ + #Nil)) + +(def'' (text:= x y) + (-> Text Text Bool) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y])) + +(def'' (get-rep key env) + (-> Text RepEnv ($' Maybe Syntax)) + (_lux_case env + #Nil + #None + + (#Cons [[k v] env']) + (if (text:= k key) + (#Some v) + (get-rep key env')))) + +(def'' (apply-template env template) + (-> RepEnv Syntax Syntax) + (_lux_case template + (#Meta [_ (#SymbolS ["" sname])]) + (_lux_case (get-rep sname env) + (#Some subst) + subst + + _ + template) + + (#Meta [_ (#TupleS elems)]) + ($tuple (map (apply-template env) elems)) + + (#Meta [_ (#FormS elems)]) + ($form (map (apply-template env) elems)) + + (#Meta [_ (#RecordS members)]) + ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [kv] + (let [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) + members)) + + _ + template)) + +(def'' (join-map f xs) + (All' [a b] + (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) + (_lux_case xs + #Nil + #Nil + + (#Cons [x xs']) + (list:++ (f x) (join-map f xs')))) + +(defmacro #export (do-template tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) + (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) + [(map% Maybe:Monad get-ident bindings) + (map% Maybe:Monad tuple->list data)]) + [(#Some bindings') (#Some data')] + (let [apply (_lux_: (-> RepEnv ($' List Syntax)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + return)) + + _ + (fail "All the do-template bindigns must be symbols.")) + + _ + (fail "Wrong syntax for do-template"))) + +(do-template [ ] + [(def'' #export ( x y) + (-> Bool) + ( x y))] + + [int:= _jvm_leq Int] + [int:> _jvm_lgt Int] + [int:< _jvm_llt Int] + [real:= _jvm_deq Real] + [real:> _jvm_dgt Real] + [real:< _jvm_dlt Real] + ) + +(do-template [ ] + [(def'' #export ( x y) + (-> ) + ( x y))] + + [int:+ _jvm_ladd Int] + [int:- _jvm_lsub Int] + [int:* _jvm_lmul Int] + [int:/ _jvm_ldiv Int] + [int:% _jvm_lrem Int] + [real:+ _jvm_dadd Real] + [real:- _jvm_dsub Real] + [real:* _jvm_dmul Real] + [real:/ _jvm_ddiv Real] + [real:% _jvm_drem Real] + ) + +(def'' (multiple? div n) + (-> Int Int Bool) + (int:= 0 (int:% n div))) + +(def'' #export (length list) + (-> List Int) + (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) + +(def'' #export (not x) + (-> Bool Bool) + (if x false true)) + +(def'' #export (text:++ x y) + (-> Text Text Text) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y])) + +(def'' (ident->text ident) + (-> Ident Text) + (let [[module name] ident] + ($ text:++ module ";" name))) + +(def'' (replace-syntax reps syntax) + (-> RepEnv Syntax Syntax) + (_lux_case syntax + (#Meta [_ (#SymbolS ["" name])]) + (_lux_case (get-rep name reps) + (#Some replacement) + replacement + + #None + syntax) + + (#Meta [_ (#FormS parts)]) + (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) + + (#Meta [_ (#TupleS members)]) + (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) + + (#Meta [_ (#RecordS slots)]) + (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[k v] slot] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))]) + + _ + syntax) + ) + +(defmacro #export (All tokens) + (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) + [self-ident tokens'] + + _ + ["" tokens]))] + (_lux_case tokens' + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case (map% Maybe:Monad get-ident args) + (#Some idents) + (_lux_case idents + #Nil + (return (_lux_: SyntaxList + (list body))) + + (#Cons [harg targs]) + (let [replacements (map (_lux_: (-> Text (, Text Syntax)) + (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) + (list& self-ident idents)) + body' (foldL (_lux_: (-> Syntax Text Syntax) + (lambda [body' arg'] + (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) + (replace-syntax replacements body) + (reverse targs))] + (return (_lux_: SyntaxList + (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) + + #None + (fail "'All' arguments must be symbols.")) + + _ + (fail "Wrong syntax for All")) + )) + +(def'' (get k plist) + (All [a] + (-> Text ($' List (, Text a)) ($' Maybe a))) + (_lux_case plist + (#Cons [[k' v] plist']) + (if (text:= k k') + (#Some v) + (get k plist')) + + #Nil + #None)) + +(def'' #export (get-module-name state) + ($' Lux Text) + (_lux_case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} + (_lux_case (reverse envs) + #Nil + (#Left "Can't get the module name without a module!") + + (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Right [state module-name])))) + +(def'' (find-macro' modules current-module module name) + (-> ($' List (, Text ($' Module Compiler))) + Text Text Text + ($' Maybe Macro)) + (do Maybe:Monad + [$module (get module modules) + gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] + (get name bindings))] + (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) + [exported? (#MacroD macro')] + (if exported? + (#Some macro') + (if (text:= module current-module) + (#Some macro') + #None)) + + [_ (#AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #None))) + +(def'' #export (find-macro ident) + (-> Ident ($' Lux ($' Maybe Macro))) + (do Lux:Monad + [current-module get-module-name] + (let [[module name] ident] + (lambda [state] + (_lux_case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} + (#Right [state (find-macro' modules current-module module name)])))))) + +(def'' (list:join xs) + (All [a] + (-> ($' List ($' List a)) ($' List a))) + (foldL list:++ #Nil xs)) + +(def'' #export (normalize ident) + (-> Ident ($' Lux Ident)) + (_lux_case ident + ["" name] + (do Lux:Monad + [module-name get-module-name] + (;return (_lux_: Ident [module-name name]))) + + _ + (return ident))) + +(defmacro #export (| tokens) + (do Lux:Monad + [pairs (map% Lux:Monad + (_lux_: (-> Syntax ($' Lux Syntax)) + (lambda [token] + (_lux_case token + (#Meta [_ (#TagS ident)]) + (do Lux:Monad + [ident (normalize ident)] + (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (;,)])))) + + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) + (do Lux:Monad + [ident (normalize ident)] + (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + + _ + (fail "Wrong syntax for |")))) + tokens)] + (;return (_lux_: SyntaxList + (list (`' (#;VariantT (;list (~@ pairs))))))))) + +(defmacro #export (& tokens) + (if (not (multiple? 2 (length tokens))) + (fail "& expects an even number of arguments.") + (do Lux:Monad + [pairs (map% Lux:Monad + (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) + (lambda [pair] + (_lux_case pair + [(#Meta [_ (#TagS ident)]) value] + (do Lux:Monad + [ident (normalize ident)] + (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + + _ + (fail "Wrong syntax for &")))) + (as-pairs tokens))] + (;return (_lux_: SyntaxList + (list (`' (#;RecordT (;list (~@ pairs)))))))))) + +(def'' #export (->text x) + (-> (^ java.lang.Object) Text) + (_jvm_invokevirtual java.lang.Object toString [] x [])) + +(def'' #export (interpose sep xs) + (All [a] + (-> a ($' List a) ($' List a))) + (_lux_case xs + #Nil + xs + + (#Cons [x #Nil]) + xs + + (#Cons [x xs']) + (list& x sep (interpose sep xs')))) + +(def'' #export (syntax:show syntax) + (-> Syntax Text) + (_lux_case syntax + (#Meta [_ (#BoolS value)]) + (->text value) + + (#Meta [_ (#IntS value)]) + (->text value) + + (#Meta [_ (#RealS value)]) + (->text value) + + (#Meta [_ (#CharS value)]) + ($ text:++ "#\"" (->text value) "\"") + + (#Meta [_ (#TextS value)]) + value + + (#Meta [_ (#SymbolS ident)]) + (ident->text ident) + + (#Meta [_ (#TagS ident)]) + (text:++ "#" (ident->text ident)) + + (#Meta [_ (#TupleS members)]) + ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) "]") + + (#Meta [_ (#FormS members)]) + ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) ")") + + (#Meta [_ (#RecordS slots)]) + ($ text:++ "{" + (|> slots + (map (_lux_: (-> (, Syntax Syntax) Text) + (lambda [slot] + (let [[k v] slot] + ($ text:++ (syntax:show k) " " (syntax:show v)))))) + (interpose " ") + (foldL text:++ "")) + "}") + )) + +(def'' #export (macro-expand syntax) + (-> Syntax ($' Lux ($' List Syntax))) + (_lux_case syntax + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + (do Lux:Monad + [macro-name' (normalize macro-name) + ?macro (find-macro (_lux_: Ident macro-name'))] + (_lux_case (_lux_: ($' Maybe Macro) ?macro) + (#Some macro) + (do Lux:Monad + [expansion (macro args) + expansion' (map% Lux:Monad macro-expand (_lux_: SyntaxList expansion))] + (;return (_lux_: SyntaxList (list:join (_lux_: ($' List SyntaxList) expansion'))))) + + #None + (do Lux:Monad + [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] + (;return (_lux_: SyntaxList (list ($form (list:join (_lux_: ($' List SyntaxList) parts'))))))))) + + (#Meta [_ (#FormS (#Cons [harg targs]))]) + (do Lux:Monad + [harg+ (macro-expand harg) + targs+ (map% Lux:Monad macro-expand (_lux_: SyntaxList targs))] + (;return (_lux_: SyntaxList (list ($form (list:++ harg+ (list:join (_lux_: ($' List SyntaxList) targs+)))))))) + + (#Meta [_ (#TupleS members)]) + (do Lux:Monad + [members' (map% Lux:Monad macro-expand members)] + (;return (_lux_: SyntaxList (list ($tuple (list:join (_lux_: ($' List SyntaxList) members'))))))) + + _ + (return (_lux_: SyntaxList (list syntax))))) + +(def'' (walk-type type) + (-> Syntax Syntax) + (_lux_case type + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + ($form (#Cons [($tag tag) (map walk-type parts)])) + + (#Meta [_ (#TupleS members)]) + ($tuple (map walk-type members)) + + (#Meta [_ (#FormS (#Cons [type-fn args]))]) + (foldL (_lux_: (-> Syntax Syntax Syntax) + (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) + (walk-type type-fn) + (map walk-type args)) + + _ + type)) + +(defmacro #export (type` tokens) + (_lux_case tokens + (#Cons [type #Nil]) + (do Lux:Monad + [type+ (macro-expand type)] + (_lux_case (_lux_: SyntaxList type+) + (#Cons [type' #Nil]) + (;return (_lux_: SyntaxList + (list (walk-type type')))) + + _ + (fail "type`: The expansion of the type-syntax had to yield a single element."))) + + _ + (fail "Wrong syntax for type`"))) + +(defmacro #export (: tokens) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (_lux_: SyntaxList + (list (`' (_lux_: (;type` (~ type)) (~ value)))))) + + _ + (fail "Wrong syntax for :"))) + +(defmacro #export (:! tokens) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (: (List Syntax) + (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) + + _ + (fail "Wrong syntax for :!"))) + +(defmacro #export (deftype tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + parts (: (Maybe (, Syntax (List Syntax) Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) + (#Some [($symbol name) #Nil type]) + + (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) + (#Some [($symbol name) args type]) + + _ + #None))] + (_lux_case parts + (#Some [name args type]) + (let [with-export (: (List Syntax) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)) + type' (: Syntax + (_lux_case args + #Nil + type + + _ + (`' (;All (~ name) [(~@ args)] (~ type)))))] + (return (: (List Syntax) + (list& (`' (_lux_def (~ name) (;type` (~ type')))) + with-export)))) + + #None + (fail "Wrong syntax for deftype")) + )) + +(deftype #export (IO a) + (-> (,) a)) + +(defmacro #export (io tokens) + (_lux_case tokens + (#Cons [value #Nil]) + (let [blank ($symbol ["" ""])] + (return (_lux_: SyntaxList + (list (`' (_lux_lambda (~ blank) (~ blank) (~ value))))))) + + _ + (fail "Wrong syntax for io"))) + +(defmacro #export (exec tokens) + (_lux_case (reverse tokens) + (#Cons [value actions]) + (let [dummy ($symbol ["" ""])] + (return (_lux_: SyntaxList + (list (foldL (: (-> Syntax Syntax Syntax) + (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) + value + actions))))) + + _ + (fail "Wrong syntax for exec"))) + +(defmacro #export (def tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) + (#Some [name args (#Some type) body]) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (#Some [name #Nil (#Some type) body]) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Some [name args #None body]) + + (#Cons [name (#Cons [body #Nil])]) + (#Some [name #Nil #None body]) + + _ + #None))] + (_lux_case parts + (#Some [name args ?type body]) + (let [body' (: Syntax + (_lux_case args + #Nil + body + + _ + (`' (;lambda (~ name) [(~@ args)] (~ body))))) + body'' (: Syntax + (_lux_case ?type + (#Some type) + (`' (: (~ type) (~ body'))) + + #None + body'))] + (return (: (List Syntax) + (list& (`' (_lux_def (~ name) (~ body''))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) + + #None + (fail "Wrong syntax for def")))) + +(def (rejoin-pair pair) + (-> (, Syntax Syntax) (List Syntax)) + (let [[left right] pair] + (list left right))) + +(defmacro #export (case tokens) + (_lux_case tokens + (#Cons [value branches]) + (do Lux:Monad + [expansions (map% Lux:Monad + (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) + (lambda expander [branch] + (let [[pattern body] branch] + (_lux_case pattern + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) + (do Lux:Monad + [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args))) + expansions (map% Lux:Monad expander (as-pairs (: (List Syntax) expansion)))] + (;return (: (List (, Syntax Syntax)) (list:join (: (List (List (, Syntax Syntax))) expansions))))) + + _ + (;return (: (List (, Syntax Syntax)) (list branch))))))) + (as-pairs branches))] + (;return (_lux_: SyntaxList + (list (`' (_lux_case (~ value) + (~@ (|> (: (List (List (, Syntax Syntax))) expansions) + list:join (map rejoin-pair) list:join)))))))) + + _ + (fail "Wrong syntax for case"))) + +(defmacro #export (\ tokens) + (case tokens + (#Cons [body (#Cons [pattern #Nil])]) + (do Lux:Monad + [pattern+ (macro-expand pattern)] + (case (: (List Syntax) pattern+) + (#Cons [pattern' #Nil]) + (;return (: (List Syntax) + (list pattern' body))) + + _ + (fail "\\ can only expand to 1 pattern."))) + + _ + (fail "Wrong syntax for \\"))) + +(defmacro #export (\or tokens) + (case tokens + (#Cons [body patterns]) + (case patterns + #Nil + (fail "\\or can't have 0 patterns") + + _ + (do Lux:Monad + [patterns' (map% Lux:Monad macro-expand patterns)] + (;return (: (List Syntax) + (list:join (map (: (-> Syntax (List Syntax)) + (lambda [pattern] (list pattern body))) + (list:join patterns'))))))) + + _ + (fail "Wrong syntax for \\or"))) + +(do-template [ ] + [(def #export (int:+ ))] + + [inc 1] + [dec -1]) + +(def (int:show int) + (-> Int Text) + (_jvm_invokevirtual java.lang.Object toString [] + int [])) + +(defmacro #export (` tokens) + (do Lux:Monad + [module-name get-module-name] + (case tokens + (\ (list template)) + (;return (_lux_: SyntaxList + (list (untemplate module-name template)))) + + _ + (fail "Wrong syntax for `")))) + +(def #export (gensym prefix state) + (-> Text (Lux Syntax)) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} + (#Right [{#source source #modules modules + #envs envs #types types #host host + #seed (inc seed) #seen-sources seen-sources #eval? eval?} + ($symbol ["__gensym__" (int:show seed)])]))) + +(def #export (macro-expand-1 token) + (-> Syntax (Lux Syntax)) + (do Lux:Monad + [token+ (macro-expand token)] + (case (: (List Syntax) token+) + (\ (list token')) + (;return token') + + _ + (fail "Macro expanded to more than 1 element.")))) + +(defmacro #export (sig tokens) + (do Lux:Monad + [tokens' (map% Lux:Monad macro-expand-1 tokens) + members (map% Lux:Monad + (: (-> Syntax (Lux (, Ident Syntax))) + (lambda [token] + (case token + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) + (do Lux:Monad + [name' (normalize name)] + (;return (: (, Ident Syntax) [name' type]))) + + _ + (fail "Signatures require typed members!")))) + tokens')] + (;return (: (List Syntax) + (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) + (lambda [pair] + (let [[name type] pair] + (`' [(~ (|> name ident->text $text)) + (~ type)])))) + members)))))))))) + +(defmacro #export (defsig tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens])) + ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) + (case tokens' + (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) + (#Some [name args sigs]) + + (\ (list& name sigs)) + (#Some [name #Nil sigs]) + + _ + #None))] + (case ?parts + (#Some [name args sigs]) + (let [sigs' (: Syntax + (case args + #Nil + (`' (;sig (~@ sigs))) + + _ + (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] + (return (: (List Syntax) + (list& (`' (_lux_def (~ name) (~ sigs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) + + #None + (fail "Wrong syntax for defsig")))) + +(defmacro #export (struct tokens) + (do Lux:Monad + [tokens' (map% Lux:Monad macro-expand-1 tokens) + members (map% Lux:Monad + (: (-> Syntax (Lux (, Syntax Syntax))) + (lambda [token] + (case token + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) + (do Lux:Monad + [name' (normalize name)] + (;return (: (, Syntax Syntax) [($tag name') value]))) + + _ + (fail "Structures require defined members!")))) + tokens')] + (;return (: (List Syntax) + (list ($record members)))))) + +(defmacro #export (defstruct tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens])) + ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) + (case tokens' + (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) + (#Some [name args type defs]) + + (\ (list& name type defs)) + (#Some [name #Nil type defs]) + + _ + #None))] + (case ?parts + (#Some [name args type defs]) + (let [defs' (: Syntax + (case args + #Nil + (`' (;struct (~@ defs))) + + _ + (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] + (return (: (List Syntax) + (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) + + #None + (fail "Wrong syntax for defsig")))) + +(defsig #export (Eq a) + (: (-> a a Bool) + =)) + +(do-template [ ] + [(defstruct #export (Eq ) + (def (= x y) + ( x y)))] + + [Int:Eq Int _jvm_leq] + [Real:Eq Real _jvm_deq]) + +(def #export (id x) + (All [a] (-> a a)) + x) + +(defsig #export (Show a) + (: (-> a Text) + show)) + +(do-template [ ] + [(defstruct #export (Show ) + (def (show x) + ))] + + [Bool:Show Bool (->text x)] + [Int:Show Int (->text x)] + [Real:Show Real (->text x)] + [Char:Show Char ($ text:++ "#\"" (->text x) "\"")]) + +(defsig #export (Ord a) + (: (-> a a Bool) + <) + (: (-> a a Bool) + <=) + (: (-> a a Bool) + >) + (: (-> a a Bool) + >=)) + +(do-template [ ] + [(defmacro #export ( tokens) + (case (reverse tokens) + (\ (list& last init)) + (return (: (List Syntax) + (list (foldL (: (-> Syntax Syntax Syntax) + (lambda [post pre] (` ))) + last + init)))) + + _ + (fail )))] + + [and (if (~ pre) true (~ post)) "and requires >=1 clauses."] + [or (if (~ pre) (~ post) false) "or requires >=1 clauses."]) + +(do-template [ ] + [(defstruct #export (Ord ) + (def (< x y) + ( x y)) + + (def (<= x y) + (or ( x y) + ( x y))) + + (def (> x y) + ( x y)) + + (def (>= x y) + (or ( x y) + ( x y))))] + + [Int:Ord Int _jvm_llt _jvm_lgt _jvm_leq] + [Real:Ord Real _jvm_dlt _jvm_dgt _jvm_deq]) + +(defmacro #export (lux tokens state) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} + (case (get "lux" modules) + (#Some lux) + (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) + (List Text)) + (lambda [gdef] + (let [[name [export? _]] gdef] + (if export? + (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [($ text:++ "Importing: " name "\n")]) + (list name)) + (list))))) + (let [{#module-aliases _ #defs defs #imports _} lux] + defs))] + (#Right [state (: (List Syntax) + (map (: (-> Text Syntax) + (lambda [name] + (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) + (list:join to-alias)))])) + + #None + (#Left "Uh, oh... The universe is not working properly...")) + )) + +(def #export (print x) + (-> Text (IO (,))) + (lambda [_] + (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [x]) + []))) + +(def #export (println x) + (-> Text (IO (,))) + (print (text:++ x "\n"))) + +(def #export (some f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #Nil + #None + + (#Cons [x xs']) + (case (f x) + #None + (some f xs') + + (#Some y) + (#Some y)))) + + +(def (index-of part text) + (-> Text Text Int) + (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String] + text [part]))) + +(def (substring1 idx text) + (-> Int Text Text) + (_jvm_invokevirtual java.lang.String substring [int] + text [(_jvm_l2i idx)])) + +(def (substring2 idx1 idx2 text) + (-> Int Int Text Text) + (_jvm_invokevirtual java.lang.String substring [int int] + text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) + +(def (split-slot slot) + (-> Text (, Text Text)) + (let [idx (index-of ";" slot) + module (substring2 0 idx slot) + name (substring1 (inc idx) slot)] + [module name])) + +(def (resolve-struct-type type) + (-> Type (Maybe Type)) + (case type + (#RecordT slots) + (#Some type) + + (#AppT [fun arg]) + (resolve-struct-type fun) + + (#AllT [_ _ _ body]) + (resolve-struct-type body) + + _ + #None)) + +(defmacro #export (using tokens state) + (case tokens + (\ (list struct body)) + (case struct + (#Meta [_ (#SymbolS vname)]) + (let [vname' (ident->text vname)] + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} + (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (lambda [env] + (case env + {#name _ #inner-closures _ #locals {#counter _ #mappings mappings} #closure _} + (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= vname' bname) + (#Some type) + #None)))) + mappings)))) + envs)] + (case ?struct-type + #None + (#Left ($ text:++ "Unknown structure: " vname')) + + (#Some struct-type) + (case (resolve-struct-type struct-type) + (#Some (#RecordT slots)) + (let [pattern ($record (map (: (-> (, Text Type) (, Syntax Syntax)) + (lambda [slot] + (let [[sname stype] slot + [module name] (split-slot sname)] + [($tag [module name]) ($symbol ["" name])]))) + slots))] + (#Right [state (: (List Syntax) + (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) + + _ + (#Left "Can only \"use\" records.")))))) + + _ + (let [dummy ($symbol ["" ""])] + (#Right [state (: (List Syntax) + (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) + (~ body))))))]))) + + _ + (#Left "Wrong syntax for defsig"))) + +(def #export (flip f) + (All [a b c] + (-> (-> a b c) (-> b a c))) + (lambda [y x] + (f x y))) + +## (def #export (curry f) +## (All [a b c] +## (-> (-> (, a b) c) +## (-> a b c))) +## (lambda [x y] +## (f [x y]))) + +## (def #export (uncurry f) +## (All [a b c] +## (-> (-> a b c) +## (-> (, a b) c))) +## (lambda [[x y]] +## (f x y))) + +## (defmacro (loop tokens) +## (_lux_case tokens +## (#Cons [bindings (#Cons [body #Nil])]) +## (let [pairs (as-pairs bindings)] +## (return (list (#FormS (#Cons [(` (lambda (~ (#SymbolS ["" "recur"])) (~ (#TupleS (map first pairs))) +## (~ body))) +## (map second pairs)]))))))) + +## (defmacro (get@ tokens) +## (let [output (_lux_case tokens +## (#Cons [tag (#Cons [record #Nil])]) +## (` (get@' (~ tag) (~ record))) + +## (#Cons [tag #Nil]) +## (` (lambda [record] (get@' (~ tag) record))))] +## (return (list output)))) + +## (defmacro (set@ tokens) +## (let [output (_lux_case tokens +## (#Cons [tag (#Cons [value (#Cons [record #Nil])])]) +## (` (set@' (~ tag) (~ value) (~ record))) + +## (#Cons [tag (#Cons [value #Nil])]) +## (` (lambda [record] (set@' (~ tag) (~ value) record))) + +## (#Cons [tag #Nil]) +## (` (lambda [value record] (set@' (~ tag) value record))))] +## (return (list output)))) + +## (defmacro (update@ tokens) +## (let [output (_lux_case tokens +## (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) +## (` (let [_record_ (~ record)] +## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_))) + +## (#Cons [tag (#Cons [func #Nil])]) +## (` (lambda [record] +## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record)))) + +## (#Cons [tag #Nil]) +## (` (lambda [func record] +## (set@' (~ tag) (func (get@' (~ tag) record)) record))))] +## (return (list output)))) diff --git a/input/program.lux b/input/program.lux new file mode 100644 index 000000000..4f329c3fa --- /dev/null +++ b/input/program.lux @@ -0,0 +1,15 @@ +(;lux) + +(def (filter p xs) + (All [a] (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + (list) + + (#;Cons [x xs']) + (if (p x) + (list& x (filter p xs')) + (filter p xs')))) + +(_jvm_program args + (println "Hello, world!")) diff --git a/source/lux.lux b/source/lux.lux deleted file mode 100644 index 07b245a5d..000000000 --- a/source/lux.lux +++ /dev/null @@ -1,2169 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -## First things first, must define functions -(_jvm_interface "lux.Function" [] - (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) - -## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] -## [(foo "java.lang.Object" ["public" "static"])] -## ( [] "void" -## ["public"] -## (_jvm_invokespecial java.lang.Object [] this [])) -## (apply [(arg "java.lang.Object")] "java.lang.Object" -## ["public"] -## "YOLO")) - -## Basic types -(_lux_def Bool (#DataT "java.lang.Boolean")) -(_lux_export Bool) - -(_lux_def Int (#DataT "java.lang.Long")) -(_lux_export Int) - -(_lux_def Real (#DataT "java.lang.Double")) -(_lux_export Real) - -(_lux_def Char (#DataT "java.lang.Character")) -(_lux_export Char) - -(_lux_def Text (#DataT "java.lang.String")) -(_lux_export Text) - -(_lux_def Void (#VariantT #Nil)) -(_lux_export Void) - -(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) -(_lux_export Ident) - -## (deftype (List a) -## (| #Nil -## (#Cons (, a (List a))))) -(_lux_def List - (#AllT [(#Some #Nil) "lux;List" "a" - (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] - (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) - #Nil])]))] - #Nil])]))])) -(_lux_export List) - -## (deftype (Maybe a) -## (| #None -## (#Some a))) -(_lux_def Maybe - (#AllT [(#Some #Nil) "lux;Maybe" "a" - (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] - (#Cons [["lux;Some" (#BoundT "a")] - #Nil])]))])) -(_lux_export Maybe) - -## (deftype #rec Type -## (| (#DataT Text) -## (#TupleT (List Type)) -## (#VariantT (List (, Text Type))) -## (#RecordT (List (, Text Type))) -## (#LambdaT (, Type Type)) -## (#BoundT Text) -## (#VarT Int) -## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) -## (#AppT (, Type Type)))) -(_lux_def Type - (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) - Type - (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) - TypeEnv - (#AppT [(#AllT [(#Some #Nil) "Type" "_" - (#VariantT (#Cons [["lux;DataT" Text] - (#Cons [["lux;TupleT" (#AppT [List Type])] - (#Cons [["lux;VariantT" TypeEnv] - (#Cons [["lux;RecordT" TypeEnv] - (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;BoundT" Text] - (#Cons [["lux;VarT" Int] - (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] - (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;ExT" Int] - #Nil])])])])])])])])])]))]) - Void])))) -(_lux_export Type) - -## (deftype (Bindings k v) -## (& #counter Int -## #mappings (List (, k v)))) -(_lux_def Bindings - (#AllT [(#Some #Nil) "lux;Bindings" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;counter" Int] - (#Cons [["lux;mappings" (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))])] - #Nil])]))])])) - -## (deftype (Env k v) -## (& #name Text -## #inner-closures Int -## #locals (Bindings k v) -## #closure (Bindings k v))) -(_lux_def Env - (#AllT [(#Some #Nil) "lux;Env" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;name" Text] - (#Cons [["lux;inner-closures" Int] - (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - #Nil])])])]))])])) - -## (deftype Cursor -## (, Text Int Int)) -(_lux_def Cursor - (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) - -## (deftype (Meta m v) -## (| (#Meta (, m v)))) -(_lux_def Meta - (#AllT [(#Some #Nil) "lux;Meta" "m" - (#AllT [#None "" "v" - (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") - (#Cons [(#BoundT "v") - #Nil])]))] - #Nil]))])])) -(_lux_export Meta) - -## (deftype (Syntax' w) -## (| (#BoolS Bool) -## (#IntS Int) -## (#RealS Real) -## (#CharS Char) -## (#TextS Text) -## (#SymbolS (, Text Text)) -## (#TagS (, Text Text)) -## (#FormS (List (w (Syntax' w)))) -## (#TupleS (List (w (Syntax' w)))) -## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) -(_lux_def Syntax' - (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "lux;Syntax'") - (#BoundT "w")])]) - Syntax - (_lux_case (#AppT [List Syntax]) - SyntaxList - (#AllT [(#Some #Nil) "lux;Syntax'" "w" - (#VariantT (#Cons [["lux;BoolS" Bool] - (#Cons [["lux;IntS" Int] - (#Cons [["lux;RealS" Real] - (#Cons [["lux;CharS" Char] - (#Cons [["lux;TextS" Text] - (#Cons [["lux;SymbolS" Ident] - (#Cons [["lux;TagS" Ident] - (#Cons [["lux;FormS" SyntaxList] - (#Cons [["lux;TupleS" SyntaxList] - (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] - #Nil]) - ])])])])])])])])]) - )])))) -(_lux_export Syntax') - -## (deftype Syntax -## (Meta Cursor (Syntax' (Meta Cursor)))) -(_lux_def Syntax - (_lux_case (#AppT [Meta Cursor]) - w - (#AppT [w (#AppT [Syntax' w])]))) -(_lux_export Syntax) - -(_lux_def SyntaxList (#AppT [List Syntax])) - -## (deftype (Either l r) -## (| (#Left l) -## (#Right r))) -(_lux_def Either - (#AllT [(#Some #Nil) "lux;Either" "l" - (#AllT [#None "" "r" - (#VariantT (#Cons [["lux;Left" (#BoundT "l")] - (#Cons [["lux;Right" (#BoundT "r")] - #Nil])]))])])) -(_lux_export Either) - -## (deftype (StateE s a) -## (-> s (Either Text (, s a)))) -(_lux_def StateE - (#AllT [(#Some #Nil) "lux;StateE" "s" - (#AllT [#None "" "a" - (#LambdaT [(#BoundT "s") - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [(#BoundT "s") - (#Cons [(#BoundT "a") - #Nil])]))])])])])) - -## (deftype Reader -## (List (Meta Cursor Text))) -(_lux_def Reader - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])])) -(_lux_export Reader) - -## (deftype HostState -## (& #writer (^ org.objectweb.asm.ClassWriter) -## #loader (^ java.net.URLClassLoader) -## #classes (^ clojure.lang.Atom))) -(_lux_def HostState - (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] - (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] - #Nil])])]))) - -## (deftype (DefData' m) -## (| #TypeD -## (#ValueD Type) -## (#MacroD m) -## (#AliasD Ident))) -(_lux_def DefData' - (#AllT [(#Some #Nil) "lux;DefData'" "" - (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] - (#Cons [["lux;ValueD" Type] - (#Cons [["lux;MacroD" (#BoundT "")] - (#Cons [["lux;AliasD" Ident] - #Nil])])])]))])) - -## (deftype LuxVar -## (| (#Local Int) -## (#Global Ident))) -(_lux_def LuxVar - (#VariantT (#Cons [["lux;Local" Int] - (#Cons [["lux;Global" Ident] - #Nil])]))) -(_lux_export LuxVar) - -## (deftype (Module Compiler) -## (& #module-aliases (List (, Text Text)) -## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) -## #imports (List Text) -## )) -(_lux_def Module - (#AllT [(#Some #Nil) "lux;Module" "Compiler" - (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] - (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - SyntaxList])])]) - #Nil])])) - #Nil])]))])] - (#Cons [["lux;imports" (#AppT [List Text])] - #Nil])])]))])) -(_lux_export Module) - -## (deftype #rec Compiler -## (& #source Reader -## #modules (List (, Text (Module Compiler))) -## #envs (List (Env Text (, LuxVar Type))) -## #types (Bindings Int Type) -## #host HostState -## #seed Int -## #seen-sources (List Text))) -(_lux_def Compiler - (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" - (#RecordT (#Cons [["lux;source" Reader] - (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) - #Nil])]))])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - (#Cons [["lux;seed" Int] - (#Cons [["lux;seen-sources" (#AppT [List Text])] - #Nil])])])])])])]))]) - Void])) -(_lux_export Compiler) - -## (deftype Macro -## (-> (List Syntax) (StateE Compiler (List Syntax)))) -(_lux_def Macro - (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE Compiler]) - SyntaxList])])) -(_lux_export Macro) - -## Base functions & macros -## (def (_meta data) -## (-> (Syntax' (Meta Cursor)) Syntax) -## (#Meta [["" -1 -1] data])) -(_lux_def _meta - (_lux_: (#LambdaT [(#AppT [Syntax' - (#AppT [Meta Cursor])]) - Syntax]) - (_lux_lambda _ data - (#Meta [["" -1 -1] data])))) - -## (def (return x) -## (All [a] -## (-> a Compiler -## (Either Text (, Compiler a)))) -## ...) -(_lux_def return - (_lux_: (#AllT [(#Some #Nil) "" "a" - (#LambdaT [(#BoundT "a") - (#LambdaT [Compiler - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [Compiler - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (_lux_lambda _ val - (_lux_lambda _ state - (#Right [state val]))))) - -## (def (fail msg) -## (All [a] -## (-> Text Compiler -## (Either Text (, Compiler a)))) -## ...) -(_lux_def fail - (_lux_: (#AllT [(#Some #Nil) "" "a" - (#LambdaT [Text - (#LambdaT [Compiler - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [Compiler - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (_lux_lambda _ msg - (_lux_lambda _ state - (#Left msg))))) - -(_lux_def $text - (_lux_: (#LambdaT [Text Syntax]) - (_lux_lambda _ text - (_meta (#TextS text))))) - -(_lux_def $symbol - (_lux_: (#LambdaT [Ident Syntax]) - (_lux_lambda _ ident - (_meta (#SymbolS ident))))) - -(_lux_def $tag - (_lux_: (#LambdaT [Ident Syntax]) - (_lux_lambda _ ident - (_meta (#TagS ident))))) - -(_lux_def $form - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) - (_lux_lambda _ tokens - (_meta (#FormS tokens))))) - -(_lux_def $tuple - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) - (_lux_lambda _ tokens - (_meta (#TupleS tokens))))) - -(_lux_def $record - (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) - (_lux_lambda _ tokens - (_meta (#RecordS tokens))))) - -(_lux_def let' - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil]))) - - _ - (fail "Wrong syntax for let'"))))) -(_lux_declare-macro let') - -(_lux_def lambda' - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS ["" ""])) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) - - (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS self)) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) - - _ - (fail "Wrong syntax for lambda"))))) -(_lux_declare-macro lambda') - -(_lux_def def' - (_lux_: Macro - (lambda' [tokens] - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])]))) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])]))) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil]))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil]))) - - _ - (fail "Wrong syntax for def") - )))) -(_lux_declare-macro def') - -(def' #export (defmacro tokens) - Macro - (_lux_case tokens - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def'"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])) - (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])]))) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def'"]) - (#Cons [($tag ["" "export"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])])) - (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])]))) - - _ - (fail "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) - -(defmacro #export (comment tokens) - (return (_lux_: SyntaxList #Nil))) - -(defmacro (->' tokens) - (_lux_case tokens - (#Cons [input (#Cons [output #Nil])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil]))) - - (#Cons [input (#Cons [output others])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil]))) - - _ - (fail "Wrong syntax for ->'"))) - -(defmacro (All' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS #Nil)]) - (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (#Cons [body - #Nil]))) - - (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) - (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) - (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) - (#Cons [(_meta (#TextS "")) - (#Cons [(_meta (#TextS arg-name)) - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) - (#Cons [(_meta (#TupleS other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil]))) - - _ - (fail "Wrong syntax for All'"))) - -(defmacro (B' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) - #Nil]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) - (#Cons [(_meta (#TextS bound-name)) - #Nil])]))) - #Nil]))) - - _ - (fail "Wrong syntax for B'"))) - -(defmacro ($' tokens) - (_lux_case tokens - (#Cons [x #Nil]) - (return tokens) - - (#Cons [x (#Cons [y xs])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) - (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil]))) - - _ - (fail "Wrong syntax for $'"))) - -(def' #export (foldL f init xs) - (All' [a b] - (->' (->' (B' a) (B' b) (B' a)) - (B' a) - ($' List (B' b)) - (B' a))) - (_lux_case xs - #Nil - init - - (#Cons [x xs']) - (foldL f (f init x) xs'))) - -(def' #export (foldR f init xs) - (All' [a b] - (->' (->' (B' b) (B' a) (B' a)) - (B' a) - ($' List (B' b)) - (B' a))) - (_lux_case xs - #Nil - init - - (#Cons [x xs']) - (f x (foldR f init xs')))) - -(def' #export (reverse list) - (All' [a] - (->' ($' List (B' a)) ($' List (B' a)))) - (foldL (_lux_: (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda' [tail head] - (#Cons [head tail]))) - #Nil - list)) - -(defmacro #export (list xs) - (return (_lux_: SyntaxList - (#Cons [(foldL (lambda' [tail head] - (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) - (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) - (_meta (#TagS ["lux" "Nil"])) - (reverse xs)) - #Nil])))) - -(defmacro #export (list& xs) - (_lux_case (reverse xs) - (#Cons [last init]) - (return (_lux_: SyntaxList - (list (foldL (lambda' [tail head] - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list head tail))))))) - last - init)))) - - _ - (fail "Wrong syntax for list&"))) - -(defmacro #export (lambda tokens) - (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) - [name tokens'] - - _ - [["" ""] tokens])) - (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case args - #Nil - (fail "lambda requires a non-empty arguments tuple.") - - (#Cons [harg targs]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol name) - harg - (foldL (lambda' [body' arg] - ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol ["" ""]) - arg - body'))) - body - (reverse targs)))))))) - - _ - (fail "Wrong syntax for lambda")))) - -(defmacro (def'' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))) - ($form (list ($symbol ["" "_lux_export"]) name))))) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - body)))) - ($form (list ($symbol ["" "_lux_export"]) name))))) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body))))))))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) type body))))))) - - _ - (fail "Wrong syntax for def") - )) - -(def'' (as-pairs xs) - (All' [a] - (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) - (_lux_case xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) - - _ - #Nil)) - -(defmacro #export (let tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (_lux_case binding - [label value] - (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) - body - (foldL (_lux_: (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda [tail head] (#Cons [head tail]))) - #Nil - (as-pairs bindings)))))) - - _ - (fail "Wrong syntax for let"))) - -(def'' #export (map f xs) - (All' [a b] - (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) - (_lux_case xs - #Nil - #Nil - - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) - -(def'' #export (any? p xs) - (All' [a] - (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) - (_lux_case xs - #Nil - false - - (#Cons [x xs']) - (_lux_case (p x) - true true - false (any? p xs')))) - -(def'' (spliced? token) - (->' Syntax Bool) - (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) - true - - _ - false)) - -(def'' (wrap-meta content) - (->' Syntax Syntax) - (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) - (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) - content))))))) - -(def'' (untemplate-list tokens) - (->' ($' List Syntax) Syntax) - (_lux_case tokens - #Nil - (_meta (#TagS ["lux" "Nil"])) - - (#Cons [token tokens']) - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list token (untemplate-list tokens'))))))))) - -(def'' (list:++ xs ys) - (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) - (_lux_case xs - (#Cons [x xs']) - (#Cons [x (list:++ xs' ys)]) - - #Nil - ys)) - -(defmacro #export ($ tokens) - (_lux_case tokens - (#Cons [op (#Cons [init args])]) - (return (_lux_: SyntaxList - (list (foldL (lambda [a1 a2] ($form (list op a1 a2))) - init - args)))) - - _ - (fail "Wrong syntax for $"))) - -(def'' (splice untemplate tag elems) - (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) - (_lux_case (any? spliced? elems) - true - (let [elems' (map (_lux_: (->' Syntax Syntax) - (lambda [elem] - (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced - - _ - ($form (list ($symbol ["" "_lux_:"]) - ($symbol ["lux" "SyntaxList"]) - ($form (list ($symbol ["lux" "list"]) (untemplate elem)))))))) - elems)] - (wrap-meta ($form (list tag - ($form (list& ($symbol ["lux" "$"]) - ($symbol ["lux" "list:++"]) - elems')))))) - - false - (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) - -(def'' (untemplate subst token) - (->' Text Syntax Syntax) - (_lux_case token - (#Meta [_ (#BoolS value)]) - (wrap-meta ($form (list ($tag ["lux" "BoolS"]) (_meta (#BoolS value))))) - - (#Meta [_ (#IntS value)]) - (wrap-meta ($form (list ($tag ["lux" "IntS"]) (_meta (#IntS value))))) - - (#Meta [_ (#RealS value)]) - (wrap-meta ($form (list ($tag ["lux" "RealS"]) (_meta (#RealS value))))) - - (#Meta [_ (#CharS value)]) - (wrap-meta ($form (list ($tag ["lux" "CharS"]) (_meta (#CharS value))))) - - (#Meta [_ (#TextS value)]) - (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value))))) - - (#Meta [_ (#TagS [module name])]) - (let [module' (_lux_case module - "" - subst - - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "TagS"]) ($tuple (list ($text module') ($text name))))))) - - (#Meta [_ (#SymbolS [module name])]) - (let [module' (_lux_case module - "" - subst - - _ - module)] - (wrap-meta ($form (list ($tag ["lux" "SymbolS"]) ($tuple (list ($text module') ($text name))))))) - - (#Meta [_ (#TupleS elems)]) - (splice (untemplate subst) ($tag ["lux" "TupleS"]) elems) - - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))]) - unquoted - - (#Meta [_ (#FormS elems)]) - (splice (untemplate subst) ($tag ["lux" "FormS"]) elems) - - (#Meta [_ (#RecordS fields)]) - (wrap-meta ($form (list ($tag ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) - (lambda [kv] - (let [[k v] kv] - ($tuple (list (untemplate subst k) (untemplate subst v)))))) - fields))))) - )) - -(defmacro (`' tokens) - (_lux_case tokens - (#Cons [template #Nil]) - (return (_lux_: SyntaxList - (list (untemplate "" template)))) - - _ - (fail "Wrong syntax for `'"))) - -(defmacro #export (|> tokens) - (_lux_case tokens - (#Cons [init apps]) - (return (_lux_: SyntaxList - (list (foldL (_lux_: (->' Syntax Syntax Syntax) - (lambda [acc app] - (_lux_case app - (#Meta [_ (#FormS parts)]) - ($form (list:++ parts (list acc))) - - _ - (`' ((~ app) (~ acc)))))) - init - apps)))) - - _ - (fail "Wrong syntax for |>"))) - -(defmacro #export (if tokens) - (_lux_case tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (_lux_: SyntaxList - (list (`' (_lux_case (~ test) - true (~ then) - false (~ else)))))) - - _ - (fail "Wrong syntax for if"))) - -## (deftype (Lux a) -## (-> Compiler (Either Text (, Compiler a)))) -(def'' #export Lux - Type - (All' [a] - (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) - -## (defsig (Monad m) -## (: (All [a] (-> a (m a))) -## return) -## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) -## bind)) -(def'' Monad - Type - (All' [m] - (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] - ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b))))])))) - -(def'' Maybe:Monad - ($' Monad Maybe) - {#lux;return - (lambda return [x] - (#Some x)) - - #lux;bind - (lambda [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) - -(def'' Lux:Monad - ($' Monad Lux) - {#lux;return - (lambda [x] - (lambda [state] - (#Right [state x]))) - - #lux;bind - (lambda [f ma] - (lambda [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) - - (#Right [state' a]) - (f a state'))))}) - -(defmacro #export (^ tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) - (return (_lux_: SyntaxList - (list (`' (#;DataT (~ (_meta (#TextS class-name)))))))) - - _ - (fail "Wrong syntax for ^"))) - -(defmacro #export (-> tokens) - (_lux_case (reverse tokens) - (#Cons [output inputs]) - (return (_lux_: SyntaxList - (list (foldL (_lux_: (->' Syntax Syntax Syntax) - (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))) - output - inputs)))) - - _ - (fail "Wrong syntax for ->"))) - -(defmacro #export (, tokens) - (return (_lux_: SyntaxList - (list (`' (#;TupleT (;list (~@ tokens)))))))) - -(defmacro (do tokens) - (_lux_case tokens - (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) - (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (_lux_case var - (#Meta [_ (#TagS ["" "let"])]) - (`' (;let (~ value) (~ body'))) - - _ - (`' (;bind (_lux_lambda (~ ($symbol ["" ""])) - (~ var) - (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (return (_lux_: SyntaxList - (list (`' (_lux_case (~ monad) - {#;return ;return #;bind ;bind} - (~ body'))))))) - - _ - (fail "Wrong syntax for do"))) - -(def'' (map% m f xs) - ## (All [m a b] - ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) - (All' [m a b] - (-> ($' Monad (B' m)) - (-> (B' a) ($' (B' m) (B' b))) - ($' List (B' a)) - ($' (B' m) ($' List (B' b))))) - (let [{#;return ;return #;bind _} m] - (_lux_case xs - #Nil - (;return (_lux_: List #Nil)) - - (#Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;return (_lux_: List (#Cons [y ys])))) - ))) - -(def'' #export (. f g) - (All' [a b c] - (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) - (lambda [x] - (f (g x)))) - -(def'' (get-ident x) - (-> Syntax ($' Maybe Text)) - (_lux_case x - (#Meta [_ (#SymbolS ["" sname])]) - (#Some sname) - - _ - #None)) - -(def'' (tuple->list tuple) - (-> Syntax ($' Maybe ($' List Syntax))) - (_lux_case tuple - (#Meta [_ (#TupleS members)]) - (#Some members) - - _ - #None)) - -(def'' RepEnv - Type - ($' List (, Text Syntax))) - -(def'' (make-env xs ys) - (-> ($' List Text) ($' List Syntax) RepEnv) - (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) - [xs ys]) - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (make-env xs' ys')]) - - _ - #Nil)) - -(def'' (text:= x y) - (-> Text Text Bool) - (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] - x [y])) - -(def'' (get-rep key env) - (-> Text RepEnv ($' Maybe Syntax)) - (_lux_case env - #Nil - #None - - (#Cons [[k v] env']) - (if (text:= k key) - (#Some v) - (get-rep key env')))) - -(def'' (apply-template env template) - (-> RepEnv Syntax Syntax) - (_lux_case template - (#Meta [_ (#SymbolS ["" sname])]) - (_lux_case (get-rep sname env) - (#Some subst) - subst - - _ - template) - - (#Meta [_ (#TupleS elems)]) - ($tuple (map (apply-template env) elems)) - - (#Meta [_ (#FormS elems)]) - ($form (map (apply-template env) elems)) - - (#Meta [_ (#RecordS members)]) - ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [kv] - (let [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) - members)) - - _ - template)) - -(def'' (join-map f xs) - (All' [a b] - (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) - (_lux_case xs - #Nil - #Nil - - (#Cons [x xs']) - (list:++ (f x) (join-map f xs')))) - -(defmacro #export (do-template tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) - (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(map% Maybe:Monad get-ident bindings) - (map% Maybe:Monad tuple->list data)]) - [(#Some bindings') (#Some data')] - (let [apply (_lux_: (-> RepEnv ($' List Syntax)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - return)) - - _ - (fail "All the do-template bindigns must be symbols.")) - - _ - (fail "Wrong syntax for do-template"))) - -(do-template [ ] - [(def'' #export ( x y) - (-> Bool) - ( x y))] - - [int:= _jvm_leq Int] - [int:> _jvm_lgt Int] - [int:< _jvm_llt Int] - [real:= _jvm_deq Real] - [real:> _jvm_dgt Real] - [real:< _jvm_dlt Real] - ) - -(do-template [ ] - [(def'' #export ( x y) - (-> ) - ( x y))] - - [int:+ _jvm_ladd Int] - [int:- _jvm_lsub Int] - [int:* _jvm_lmul Int] - [int:/ _jvm_ldiv Int] - [int:% _jvm_lrem Int] - [real:+ _jvm_dadd Real] - [real:- _jvm_dsub Real] - [real:* _jvm_dmul Real] - [real:/ _jvm_ddiv Real] - [real:% _jvm_drem Real] - ) - -(def'' (multiple? div n) - (-> Int Int Bool) - (int:= 0 (int:% n div))) - -(def'' #export (length list) - (-> List Int) - (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) - -(def'' #export (not x) - (-> Bool Bool) - (if x false true)) - -(def'' #export (text:++ x y) - (-> Text Text Text) - (_jvm_invokevirtual java.lang.String concat [java.lang.String] - x [y])) - -(def'' (ident->text ident) - (-> Ident Text) - (let [[module name] ident] - ($ text:++ module ";" name))) - -(def'' (replace-syntax reps syntax) - (-> RepEnv Syntax Syntax) - (_lux_case syntax - (#Meta [_ (#SymbolS ["" name])]) - (_lux_case (get-rep name reps) - (#Some replacement) - replacement - - #None - syntax) - - (#Meta [_ (#FormS parts)]) - (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) - - (#Meta [_ (#TupleS members)]) - (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - - (#Meta [_ (#RecordS slots)]) - (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))]) - - _ - syntax) - ) - -(defmacro #export (All tokens) - (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) - [self-ident tokens'] - - _ - ["" tokens]))] - (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe:Monad get-ident args) - (#Some idents) - (_lux_case idents - #Nil - (return (_lux_: SyntaxList - (list body))) - - (#Cons [harg targs]) - (let [replacements (map (_lux_: (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) - (list& self-ident idents)) - body' (foldL (_lux_: (-> Syntax Text Syntax) - (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) - (replace-syntax replacements body) - (reverse targs))] - (return (_lux_: SyntaxList - (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) - - #None - (fail "'All' arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) - )) - -(def'' (get k plist) - (All [a] - (-> Text ($' List (, Text a)) ($' Maybe a))) - (_lux_case plist - (#Cons [[k' v] plist']) - (if (text:= k k') - (#Some v) - (get k plist')) - - #Nil - #None)) - -(def'' #export (get-module-name state) - ($' Lux Text) - (_lux_case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #seen-sources seen-sources} - (_lux_case (reverse envs) - #Nil - (#Left "Can't get the module name without a module!") - - (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) - (#Right [state module-name])))) - -(def'' (find-macro' modules current-module module name) - (-> ($' List (, Text ($' Module Compiler))) - Text Text Text - ($' Maybe Macro)) - (do Maybe:Monad - [$module (get module modules) - gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] - (get name bindings))] - (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) - [exported? (#MacroD macro')] - (if exported? - (#Some macro') - (if (text:= module current-module) - (#Some macro') - #None)) - - [_ (#AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) - - _ - #None))) - -(def'' #export (find-macro ident) - (-> Ident ($' Lux ($' Maybe Macro))) - (do Lux:Monad - [current-module get-module-name] - (let [[module name] ident] - (lambda [state] - (_lux_case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #seen-sources seen-sources} - (#Right [state (find-macro' modules current-module module name)])))))) - -(def'' (list:join xs) - (All [a] - (-> ($' List ($' List a)) ($' List a))) - (foldL list:++ #Nil xs)) - -(def'' #export (normalize ident) - (-> Ident ($' Lux Ident)) - (_lux_case ident - ["" name] - (do Lux:Monad - [module-name get-module-name] - (;return (_lux_: Ident [module-name name]))) - - _ - (return ident))) - -(defmacro #export (| tokens) - (do Lux:Monad - [pairs (map% Lux:Monad - (_lux_: (-> Syntax ($' Lux Syntax)) - (lambda [token] - (_lux_case token - (#Meta [_ (#TagS ident)]) - (do Lux:Monad - [ident (normalize ident)] - (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (;,)])))) - - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) - (do Lux:Monad - [ident (normalize ident)] - (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) - - _ - (fail "Wrong syntax for |")))) - tokens)] - (;return (_lux_: SyntaxList - (list (`' (#;VariantT (;list (~@ pairs))))))))) - -(defmacro #export (& tokens) - (if (not (multiple? 2 (length tokens))) - (fail "& expects an even number of arguments.") - (do Lux:Monad - [pairs (map% Lux:Monad - (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) - (lambda [pair] - (_lux_case pair - [(#Meta [_ (#TagS ident)]) value] - (do Lux:Monad - [ident (normalize ident)] - (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) - - _ - (fail "Wrong syntax for &")))) - (as-pairs tokens))] - (;return (_lux_: SyntaxList - (list (`' (#;RecordT (;list (~@ pairs)))))))))) - -(def'' #export (->text x) - (-> (^ java.lang.Object) Text) - (_jvm_invokevirtual java.lang.Object toString [] x [])) - -(def'' #export (interpose sep xs) - (All [a] - (-> a ($' List a) ($' List a))) - (_lux_case xs - #Nil - xs - - (#Cons [x #Nil]) - xs - - (#Cons [x xs']) - (list& x sep (interpose sep xs')))) - -(def'' #export (syntax:show syntax) - (-> Syntax Text) - (_lux_case syntax - (#Meta [_ (#BoolS value)]) - (->text value) - - (#Meta [_ (#IntS value)]) - (->text value) - - (#Meta [_ (#RealS value)]) - (->text value) - - (#Meta [_ (#CharS value)]) - ($ text:++ "#\"" (->text value) "\"") - - (#Meta [_ (#TextS value)]) - value - - (#Meta [_ (#SymbolS ident)]) - (ident->text ident) - - (#Meta [_ (#TagS ident)]) - (text:++ "#" (ident->text ident)) - - (#Meta [_ (#TupleS members)]) - ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) "]") - - (#Meta [_ (#FormS members)]) - ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) ")") - - (#Meta [_ (#RecordS slots)]) - ($ text:++ "{" - (|> slots - (map (_lux_: (-> (, Syntax Syntax) Text) - (lambda [slot] - (let [[k v] slot] - ($ text:++ (syntax:show k) " " (syntax:show v)))))) - (interpose " ") - (foldL text:++ "")) - "}") - )) - -(def'' #export (macro-expand syntax) - (-> Syntax ($' Lux ($' List Syntax))) - (_lux_case syntax - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) - (do Lux:Monad - [macro-name' (normalize macro-name) - ?macro (find-macro (_lux_: Ident macro-name'))] - (_lux_case (_lux_: ($' Maybe Macro) ?macro) - (#Some macro) - (do Lux:Monad - [expansion (macro args) - expansion' (map% Lux:Monad macro-expand (_lux_: SyntaxList expansion))] - (;return (_lux_: SyntaxList (list:join (_lux_: ($' List SyntaxList) expansion'))))) - - #None - (do Lux:Monad - [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] - (;return (_lux_: SyntaxList (list ($form (list:join (_lux_: ($' List SyntaxList) parts'))))))))) - - (#Meta [_ (#FormS (#Cons [harg targs]))]) - (do Lux:Monad - [harg+ (macro-expand harg) - targs+ (map% Lux:Monad macro-expand (_lux_: SyntaxList targs))] - (;return (_lux_: SyntaxList (list ($form (list:++ harg+ (list:join (_lux_: ($' List SyntaxList) targs+)))))))) - - (#Meta [_ (#TupleS members)]) - (do Lux:Monad - [members' (map% Lux:Monad macro-expand members)] - (;return (_lux_: SyntaxList (list ($tuple (list:join (_lux_: ($' List SyntaxList) members'))))))) - - _ - (return (_lux_: SyntaxList (list syntax))))) - -(def'' (walk-type type) - (-> Syntax Syntax) - (_lux_case type - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) - ($form (#Cons [($tag tag) (map walk-type parts)])) - - (#Meta [_ (#TupleS members)]) - ($tuple (map walk-type members)) - - (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (foldL (_lux_: (-> Syntax Syntax Syntax) - (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) - (walk-type type-fn) - (map walk-type args)) - - _ - type)) - -(defmacro #export (type` tokens) - (_lux_case tokens - (#Cons [type #Nil]) - (do Lux:Monad - [type+ (macro-expand type)] - (_lux_case (_lux_: SyntaxList type+) - (#Cons [type' #Nil]) - (;return (_lux_: SyntaxList - (list (walk-type type')))) - - _ - (fail "type`: The expansion of the type-syntax had to yield a single element."))) - - _ - (fail "Wrong syntax for type`"))) - -(defmacro #export (: tokens) - (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (_lux_: SyntaxList - (list (`' (_lux_: (;type` (~ type)) (~ value)))))) - - _ - (fail "Wrong syntax for :"))) - -(defmacro #export (:! tokens) - (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (: (List Syntax) - (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) - - _ - (fail "Wrong syntax for :!"))) - -(defmacro #export (deftype tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] - - _ - [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) - (#Some [($symbol name) #Nil type]) - - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) - (#Some [($symbol name) args type]) - - _ - #None))] - (_lux_case parts - (#Some [name args type]) - (let [with-export (: (List Syntax) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)) - type' (: Syntax - (_lux_case args - #Nil - type - - _ - (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (: (List Syntax) - (list& (`' (_lux_def (~ name) (;type` (~ type')))) - with-export)))) - - #None - (fail "Wrong syntax for deftype")) - )) - -(deftype #export (IO a) - (-> (,) a)) - -(defmacro #export (io tokens) - (_lux_case tokens - (#Cons [value #Nil]) - (let [blank ($symbol ["" ""])] - (return (_lux_: SyntaxList - (list (`' (_lux_lambda (~ blank) (~ blank) (~ value))))))) - - _ - (fail "Wrong syntax for io"))) - -(defmacro #export (exec tokens) - (_lux_case (reverse tokens) - (#Cons [value actions]) - (let [dummy ($symbol ["" ""])] - (return (_lux_: SyntaxList - (list (foldL (: (-> Syntax Syntax Syntax) - (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) - value - actions))))) - - _ - (fail "Wrong syntax for exec"))) - -(defmacro #export (def tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] - - _ - [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (#Some [name args (#Some type) body]) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (#Some [name #Nil (#Some type) body]) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) - - (#Cons [name (#Cons [body #Nil])]) - (#Some [name #Nil #None body]) - - _ - #None))] - (_lux_case parts - (#Some [name args ?type body]) - (let [body' (: Syntax - (_lux_case args - #Nil - body - - _ - (`' (;lambda (~ name) [(~@ args)] (~ body))))) - body'' (: Syntax - (_lux_case ?type - (#Some type) - (`' (: (~ type) (~ body'))) - - #None - body'))] - (return (: (List Syntax) - (list& (`' (_lux_def (~ name) (~ body''))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) - - #None - (fail "Wrong syntax for def")))) - -(def (rejoin-pair pair) - (-> (, Syntax Syntax) (List Syntax)) - (let [[left right] pair] - (list left right))) - -(defmacro #export (case tokens) - (_lux_case tokens - (#Cons [value branches]) - (do Lux:Monad - [expansions (map% Lux:Monad - (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) - (lambda expander [branch] - (let [[pattern body] branch] - (_lux_case pattern - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) - (do Lux:Monad - [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args))) - expansions (map% Lux:Monad expander (as-pairs (: (List Syntax) expansion)))] - (;return (: (List (, Syntax Syntax)) (list:join (: (List (List (, Syntax Syntax))) expansions))))) - - _ - (;return (: (List (, Syntax Syntax)) (list branch))))))) - (as-pairs branches))] - (;return (_lux_: SyntaxList - (list (`' (_lux_case (~ value) - (~@ (|> (: (List (List (, Syntax Syntax))) expansions) - list:join (map rejoin-pair) list:join)))))))) - - _ - (fail "Wrong syntax for case"))) - -(defmacro #export (\ tokens) - (case tokens - (#Cons [body (#Cons [pattern #Nil])]) - (do Lux:Monad - [pattern+ (macro-expand pattern)] - (case (: (List Syntax) pattern+) - (#Cons [pattern' #Nil]) - (;return (: (List Syntax) - (list pattern' body))) - - _ - (fail "\\ can only expand to 1 pattern."))) - - _ - (fail "Wrong syntax for \\"))) - -(defmacro #export (\or tokens) - (case tokens - (#Cons [body patterns]) - (case patterns - #Nil - (fail "\\or can't have 0 patterns") - - _ - (do Lux:Monad - [patterns' (map% Lux:Monad macro-expand patterns)] - (;return (: (List Syntax) - (list:join (map (: (-> Syntax (List Syntax)) - (lambda [pattern] (list pattern body))) - (list:join patterns'))))))) - - _ - (fail "Wrong syntax for \\or"))) - -(do-template [ ] - [(def #export (int:+ ))] - - [inc 1] - [dec -1]) - -(def (int:show int) - (-> Int Text) - (_jvm_invokevirtual java.lang.Object toString [] - int [])) - -(defmacro #export (` tokens) - (do Lux:Monad - [module-name get-module-name] - (case tokens - (\ (list template)) - (;return (_lux_: SyntaxList - (list (untemplate module-name template)))) - - _ - (fail "Wrong syntax for `")))) - -(def #export (gensym prefix state) - (-> Text (Lux Syntax)) - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #seen-sources seen-sources} - (#Right [{#source source #modules modules - #envs envs #types types #host host - #seed (inc seed) #seen-sources seen-sources} - ($symbol ["__gensym__" (int:show seed)])]))) - -(def #export (macro-expand-1 token) - (-> Syntax (Lux Syntax)) - (do Lux:Monad - [token+ (macro-expand token)] - (case (: (List Syntax) token+) - (\ (list token')) - (;return token') - - _ - (fail "Macro expanded to more than 1 element.")))) - -(defmacro #export (sig tokens) - (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand-1 tokens) - members (map% Lux:Monad - (: (-> Syntax (Lux (, Ident Syntax))) - (lambda [token] - (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) - (do Lux:Monad - [name' (normalize name)] - (;return (: (, Ident Syntax) [name' type]))) - - _ - (fail "Signatures require typed members!")))) - tokens')] - (;return (: (List Syntax) - (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) - (lambda [pair] - (let [[name type] pair] - (`' [(~ (|> name ident->text $text)) - (~ type)])))) - members)))))))))) - -(defmacro #export (defsig tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) - [true tokens'] - - _ - [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) - (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) - (#Some [name args sigs]) - - (\ (list& name sigs)) - (#Some [name #Nil sigs]) - - _ - #None))] - (case ?parts - (#Some [name args sigs]) - (let [sigs' (: Syntax - (case args - #Nil - (`' (;sig (~@ sigs))) - - _ - (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (: (List Syntax) - (list& (`' (_lux_def (~ name) (~ sigs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) - - #None - (fail "Wrong syntax for defsig")))) - -(defmacro #export (struct tokens) - (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand-1 tokens) - members (map% Lux:Monad - (: (-> Syntax (Lux (, Syntax Syntax))) - (lambda [token] - (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) - (do Lux:Monad - [name' (normalize name)] - (;return (: (, Syntax Syntax) [($tag name') value]))) - - _ - (fail "Structures require defined members!")))) - tokens')] - (;return (: (List Syntax) - (list ($record members)))))) - -(defmacro #export (defstruct tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) - [true tokens'] - - _ - [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) - (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) - (#Some [name args type defs]) - - (\ (list& name type defs)) - (#Some [name #Nil type defs]) - - _ - #None))] - (case ?parts - (#Some [name args type defs]) - (let [defs' (: Syntax - (case args - #Nil - (`' (;struct (~@ defs))) - - _ - (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (: (List Syntax) - (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) - - #None - (fail "Wrong syntax for defsig")))) - -(defsig #export (Eq a) - (: (-> a a Bool) - =)) - -(do-template [ ] - [(defstruct #export (Eq ) - (def (= x y) - ( x y)))] - - [Int:Eq Int _jvm_leq] - [Real:Eq Real _jvm_deq]) - -(def #export (id x) - (All [a] (-> a a)) - x) - -(defsig #export (Show a) - (: (-> a Text) - show)) - -(do-template [ ] - [(defstruct #export (Show ) - (def (show x) - ))] - - [Bool:Show Bool (->text x)] - [Int:Show Int (->text x)] - [Real:Show Real (->text x)] - [Char:Show Char ($ text:++ "#\"" (->text x) "\"")]) - -(defsig #export (Ord a) - (: (-> a a Bool) - <) - (: (-> a a Bool) - <=) - (: (-> a a Bool) - >) - (: (-> a a Bool) - >=)) - -(do-template [ ] - [(defmacro #export ( tokens) - (case (reverse tokens) - (\ (list& last init)) - (return (: (List Syntax) - (list (foldL (: (-> Syntax Syntax Syntax) - (lambda [post pre] (` ))) - last - init)))) - - _ - (fail )))] - - [and (if (~ pre) true (~ post)) "and requires >=1 clauses."] - [or (if (~ pre) (~ post) false) "or requires >=1 clauses."]) - -(do-template [ ] - [(defstruct #export (Ord ) - (def (< x y) - ( x y)) - - (def (<= x y) - (or ( x y) - ( x y))) - - (def (> x y) - ( x y)) - - (def (>= x y) - (or ( x y) - ( x y))))] - - [Int:Ord Int _jvm_llt _jvm_lgt _jvm_leq] - [Real:Ord Real _jvm_dlt _jvm_dgt _jvm_deq]) - -(defmacro #export (lux tokens state) - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #seen-sources seen-sources} - (case (get "lux" modules) - (#Some lux) - (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (list name) - (list))))) - (let [{#module-aliases _ #defs defs #imports _} lux] - defs))] - (#Right [state (: (List Syntax) - (map (: (-> Text Syntax) - (lambda [name] - (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) - (list:join to-alias)))])) - - #None - (#Left "Uh, oh... The universe is not working properly...")) - )) - -(def #export (print x) - (-> Text (IO (,))) - (lambda [_] - (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) [x]) - []))) - -(def #export (println x) - (-> Text (IO (,))) - (print (text:++ x "\n"))) - -(def #export (some f xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #Nil - #None - - (#Cons [x xs']) - (case (f x) - #None - (some f xs') - - (#Some y) - (#Some y)))) - - -(def (index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String] - text [part]))) - -(def (substring1 idx text) - (-> Int Text Text) - (_jvm_invokevirtual java.lang.String substring [int] - text [(_jvm_l2i idx)])) - -(def (substring2 idx1 idx2 text) - (-> Int Int Text Text) - (_jvm_invokevirtual java.lang.String substring [int int] - text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) - -(def (split-slot slot) - (-> Text (, Text Text)) - (let [idx (index-of ";" slot) - module (substring2 0 idx slot) - name (substring1 (inc idx) slot)] - [module name])) - -(def (resolve-struct-type type) - (-> Type (Maybe Type)) - (case type - (#RecordT slots) - (#Some type) - - (#AppT [fun arg]) - (resolve-struct-type fun) - - (#AllT [_ _ _ body]) - (resolve-struct-type body) - - _ - #None)) - -(defmacro #export (using tokens state) - (case tokens - (\ (list struct body)) - (case struct - (#Meta [_ (#SymbolS vname)]) - (let [vname' (ident->text vname)] - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #seen-sources seen-sources} - (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#name _ #inner-closures _ #locals {#counter _ #mappings mappings} #closure _} - (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#Some type) - #None)))) - mappings)))) - envs)] - (case ?struct-type - #None - (#Left ($ text:++ "Unknown structure: " vname')) - - (#Some struct-type) - (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) - (let [pattern ($record (map (: (-> (, Text Type) (, Syntax Syntax)) - (lambda [slot] - (let [[sname stype] slot - [module name] (split-slot sname)] - [($tag [module name]) ($symbol ["" name])]))) - slots))] - (#Right [state (: (List Syntax) - (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) - - _ - (#Left "Can only \"use\" records.")))))) - - _ - (let [dummy ($symbol ["" ""])] - (#Right [state (: (List Syntax) - (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) - (~ body))))))]))) - - _ - (#Left "Wrong syntax for defsig"))) - -(def #export (flip f) - (All [a b c] - (-> (-> a b c) (-> b a c))) - (lambda [y x] - (f x y))) - -## (def #export (curry f) -## (All [a b c] -## (-> (-> (, a b) c) -## (-> a b c))) -## (lambda [x y] -## (f [x y]))) - -## (def #export (uncurry f) -## (All [a b c] -## (-> (-> a b c) -## (-> (, a b) c))) -## (lambda [[x y]] -## (f x y))) - -## (defmacro (loop tokens) -## (_lux_case tokens -## (#Cons [bindings (#Cons [body #Nil])]) -## (let [pairs (as-pairs bindings)] -## (return (list (#FormS (#Cons [(` (lambda (~ (#SymbolS ["" "recur"])) (~ (#TupleS (map first pairs))) -## (~ body))) -## (map second pairs)]))))))) - -## (defmacro (get@ tokens) -## (let [output (_lux_case tokens -## (#Cons [tag (#Cons [record #Nil])]) -## (` (get@' (~ tag) (~ record))) - -## (#Cons [tag #Nil]) -## (` (lambda [record] (get@' (~ tag) record))))] -## (return (list output)))) - -## (defmacro (set@ tokens) -## (let [output (_lux_case tokens -## (#Cons [tag (#Cons [value (#Cons [record #Nil])])]) -## (` (set@' (~ tag) (~ value) (~ record))) - -## (#Cons [tag (#Cons [value #Nil])]) -## (` (lambda [record] (set@' (~ tag) (~ value) record))) - -## (#Cons [tag #Nil]) -## (` (lambda [value record] (set@' (~ tag) value record))))] -## (return (list output)))) - -## (defmacro (update@ tokens) -## (let [output (_lux_case tokens -## (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) -## (` (let [_record_ (~ record)] -## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_))) - -## (#Cons [tag (#Cons [func #Nil])]) -## (` (lambda [record] -## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record)))) - -## (#Cons [tag #Nil]) -## (` (lambda [func record] -## (set@' (~ tag) (func (get@' (~ tag) record)) record))))] -## (return (list output)))) diff --git a/source/program.lux b/source/program.lux deleted file mode 100644 index 364c57d89..000000000 --- a/source/program.lux +++ /dev/null @@ -1,15 +0,0 @@ -(;lux) - -(def (filter p xs) - (All [a] (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - (list) - - (#;Cons [x xs']) - (if (p x) - (list& x (filter p xs')) - (filter p xs')))) - -(_jvm_program _ - (println "Hello, world!")) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 4cb1a4900..039db810a 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -108,7 +108,7 @@ ["lux;Cons" [?type ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-coerce analyse eval! ?type ?value) + (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] @@ -459,7 +459,7 @@ (if (.startsWith msg "@") msg (|let [[file line col] meta] - (str "@ " file " : " line " , " col "\n" msg)))) + (str "@ " file "," line "," col "\n" msg)))) (defn ^:private analyse-basic-ast [analyse eval! compile-module exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) @@ -519,7 +519,8 @@ (fail* (add-loc meta msg))) [["lux;Left" msg]] - (fail* (add-loc meta msg)))))) + (fail* (add-loc meta msg)) + )))) (defn ^:private analyse-ast [eval! compile-module exo-type token] (matchv ::M/objects [token] @@ -531,7 +532,8 @@ (fn [state] (matchv ::M/objects [((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state)] [["lux;Right" [state* =fn]]] - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type =fn ?args) state*) + (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) exo-type =fn ?args) state*)) [_] ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 1aa683ea6..b9361b8c3 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -353,6 +353,6 @@ (defn analyse-jvm-program [analyse ?args ?body] (|do [=body (&/with-scope "" - (&&env/with-local "" (&/V "lux;AppT" (&/T &type/List &type/Text)) + (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text)) (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))] (return (&/|list (&/V "jvm-program" =body))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 242539b65..90811c77e 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -103,6 +103,7 @@ (|do [module-name &/get-module-name] (fn [state] (|let [[?module ?name] ident + ;; _ (prn 'analyse-symbol/_0 ?module ?name) local-ident (str ?module ";" ?name) stack (&/get$ &/$ENVS state) no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not) @@ -110,67 +111,77 @@ [inner outer] (&/|split-with no-binding? stack)] (matchv ::M/objects [outer] [["lux;Nil" _]] - ((|do [[[r-module r-name] $def] (&&module/find-def (if (.equals "" ?module) module-name ?module) - ?name) - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) + (do ;; (prn 'analyse-symbol/_1 + ;; [?module ?name] + ;; [(if (.equals "" ?module) module-name ?module) + ;; ?name]) + ((|do [[[r-module r-name] $def] (&&module/find-def (if (.equals "" ?module) module-name ?module) + ?name) + ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" ?type]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state)) [["lux;Cons" [?genv ["lux;Nil" _]]]] - (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] - (matchv ::M/objects [global] - [[["lux;Global" [?module* ?name*]] _]] - ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) - - [_] - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")) - (fail* "_{_ analyse-symbol _}_")) - + (do ;; (prn 'analyse-symbol/_2 ?module ?name local-ident (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] + (do ;; (prn 'analyse-symbol/_2.1 ?module ?name local-ident (aget global 0)) + (matchv ::M/objects [global] + [[["lux;Global" [?module* ?name*]] _]] + ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) + ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" ?type]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state) + + [_] + (do ;; (prn 'analyse-symbol/_2.1.2 ?module ?name local-ident) + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) + (fail* "_{_ analyse-symbol _}_"))) + [["lux;Cons" [top-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 (&/|cons module-name (&/|reverse in-scope)) ident register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) - (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) - (&/|list)) - (&/|reverse inner) scopes)] - ((|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] - (return (&/|list =local))) - (&/set$ &/$ENVS (&/|++ inner* outer) state))) + (do ;; (prn 'analyse-symbol/_3 ?module ?name) + (|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) ident register frame)] + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) + (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) + (&/|list)) + (&/|reverse inner) scopes)] + ((|do [btype (&&/expr-type =local) + _ (&type/check exo-type btype)] + (return (&/|list =local))) + (&/set$ &/$ENVS (&/|++ inner* outer) state)))) ))) )) @@ -345,6 +356,7 @@ (defn analyse-coerce [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) + _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] (return (&/|list (&/T (&/V "ann" (&/T =value =type)) ==type))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 1fd96ce0a..f0e5b82b4 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -56,9 +56,31 @@ nil) [_] - (fail* "[Analyser Error] Can't create a new global definition outside of a global environment.")))) + (fail* (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name))))) + +(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))] + (matchv ::M/objects [$def] + [["lux;TypeD" _]] + (return* state &type/Type) + + [["lux;MacroD" _]] + (return* state &type/Macro) + + [["lux;ValueD" _type]] + (return* state _type) + + [["lux;AliasD" [?r-module ?r-name]]] + (&/run-state (def-type ?r-module ?r-name) + state)) + (fail* (str "[Analyser Error] Unknown definition: " (str 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] (matchv ::M/objects [(&/get$ &/$ENVS state)] [["lux;Cons" [?env ["lux;Nil" _]]]] @@ -75,6 +97,7 @@ (&/update$ &/$MAPPINGS (fn [mappings] (&/|put (str "" &/+name-separator+ a-name) (&/T (&/V "lux;Global" (&/T r-module r-name)) type) + ;; (aget (->> state (&/get$ &/$MODULES) (&/|get r-module) (&/get$ $DEFS) (&/|get r-name)) 1) mappings)) locals)) ?env)))) @@ -112,20 +135,24 @@ (defn find-def [module name] (|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) (&/get$ $DEFS))] - (if-let [$def (&/|get name $module)] - (matchv ::M/objects [$def] - [[exported? $$def]] - (if (or exported? (.equals ^Object current-module module)) - (matchv ::M/objects [$$def] - [["lux;AliasD" [?r-module ?r-name]]] - ((find-def ?r-module ?r-name) - state) - - [_] - (return* state (&/T (&/T module name) $$def))) - (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name))))) - (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name)))) + (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) + (if-let [$def (&/|get name $module)] + (matchv ::M/objects [$def] + [[exported? $$def]] + (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) + (if (or exported? (.equals ^Object current-module module)) + (matchv ::M/objects [$$def] + [["lux;AliasD" [?r-module ?r-name]]] + (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) + ((find-def ?r-module ?r-name) + state)) + + [_] + (return* state (&/T (&/T module name) $$def))) + (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) + (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name))))) (do (prn [module name] (str "[Analyser Error] Module doesn't exist: " module) (->> state (&/get$ &/$MODULES) &/|keys &/->seq)) @@ -144,7 +171,7 @@ [[exported? ["lux;ValueD" ?type]]] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (&host/location (&/|list module name))) + :let [macro (-> (.loadClass loader (str module ".$" (&/normalize-ident name))) (.getField "_datum") (.get nil))]] (fn [state*] @@ -199,18 +226,19 @@ (|let [[k v] kv] (matchv ::M/objects [v] [[?exported? ?def]] - (matchv ::M/objects [?def] - [["lux;AliasD" [?r-module ?r-name]]] - (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) - - [["lux;MacroD" _]] - (&/T ?exported? k "M") - - [["lux;TypeD" _]] - (&/T ?exported? k "T") - - [_] - (&/T ?exported? k "V"))))) + (do ;; (prn 'defs k ?exported?) + (matchv ::M/objects [?def] + [["lux;AliasD" [?r-module ?r-name]]] + (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) + + [["lux;MacroD" _]] + (&/T ?exported? k "M") + + [["lux;TypeD" _]] + (&/T ?exported? k "T") + + [_] + (&/T ?exported? k "V")))))) (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))))))) (def imports diff --git a/src/lux/base.clj b/src/lux/base.clj index 657ebd51e..aecb3fd13 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -21,12 +21,13 @@ ;; CompilerState (def $ENVS 0) -(def $HOST 1) -(def $MODULES 2) -(def $SEED 3) -(def $SEEN-SOURCES 4) -(def $SOURCE 5) -(def $TYPES 6) +(def $EVAL? 1) +(def $HOST 2) +(def $MODULES 3) +(def $SEED 4) +(def $SEEN-SOURCES 5) +(def $SOURCE 6) +(def $TYPES 7) ;; [Exports] (def +name-separator+ ";") @@ -413,6 +414,7 @@ \< "_LT_" \> "_GT_" \~ "_TILDE_" + \| "_PIPE_" ;; default char)) @@ -456,7 +458,8 @@ ;; (prn 'findClass class-name) (if-let [^bytes bytecode (get @store class-name)] (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) - (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))) + (do (prn 'memory-class-loader/store (keys @store)) + (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))) (defn host [_] (let [store (atom {})] @@ -471,6 +474,8 @@ (defn init-state [_] (R ;; "lux;envs" (|list) + ;; "lux;eval?" + false ;; "lux;host" (host nil) ;; "lux;modules" @@ -485,6 +490,19 @@ +init-bindings+ )) +(defn with-eval [body] + (fn [state] + (matchv ::M/objects [(body (set$ $EVAL? true state))] + [["lux;Right" [state* output]]] + (return* (set$ $EVAL? (get$ $EVAL? state) state*) output) + + [["lux;Left" msg]] + (fail* msg)))) + +(def get-eval + (fn [state] + (return* state (get$ $EVAL? state)))) + (def get-writer (fn [state] (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] @@ -557,9 +575,8 @@ state)))))) (def get-scope-name - (|do [module-name get-module-name] - (fn [state] - (return* state (->> state (get$ $ENVS) (|map #(get$ $NAME %)) |reverse (|cons module-name)))))) + (fn [state] + (return* state (->> state (get$ $ENVS) (|map #(get$ $NAME %)) |reverse)))) (defn with-writer [writer body] (fn [state] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 90a382ed5..d88c33437 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -25,9 +25,6 @@ ClassWriter MethodVisitor))) -;; [Constants] -(def ^:private version "0.2") - ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] (matchv ::M/objects [syntax] @@ -321,80 +318,104 @@ (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) (defn ^:private eval! [expr] - (|do [id &/gen-id - :let [class-name (str id) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - class-name nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil) - (doto (.visitEnd))))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitCode *writer*)] - _ (compile-expression expr) - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC class-name "_eval" "Ljava/lang/Object;") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [bytecode (.toByteArray (doto =class - .visitEnd))] - _ (&&/save-class! class-name bytecode) - loader &/loader] - (-> (.loadClass ^ClassLoader loader class-name) - (.getField "_eval") - (.get nil) - return))) + (&/with-eval + (|do [module &/get-module-name + id &/gen-id + :let [class-name (str module "/" id) + ;; _ (prn 'eval! id class-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + class-name nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil) + (doto (.visitEnd))))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitCode *writer*)] + _ (compile-expression expr) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/PUTSTATIC class-name "_eval" "Ljava/lang/Object;") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [bytecode (.toByteArray (doto =class + .visitEnd))] + _ (&&/save-class! (str id) bytecode) + loader &/loader] + (-> (.loadClass ^ClassLoader loader (str module "." id)) + (.getField "_eval") + (.get nil) + return)))) (defn ^:private compile-module [name] - (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] - (&/map% compile-statement analysis+))] - (fn [state] - (if (->> state (&/get$ &/$MODULES) (&/|contains? name)) - (if (.equals ^Object name "lux") - (return* state nil) - (fail* "[Compiler Error] Can't redefine a module!")) - (let [file-name (str "source/" name ".lux") - file-content (slurp file-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (&host/->class name) nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil (hash file-content)) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil version) - .visitEnd))] - (matchv ::M/objects [((&/exhaust% compiler-step) - (->> state - (&/set$ &/$SOURCE (&reader/from file-name file-content)) - (&/set$ &/$ENVS (&/|list (&/env name))) - (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %)) - (&/update$ &/$MODULES #(&/|put name &a-module/init-module %))))] - [["lux;Right" [?state _]]] - (&/run-state (|do [defs &a-module/defs - imports &a-module/imports - :let [_ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil - (->> defs - (&/|map (fn [_def] - (|let [[?exported ?name ?ann] _def] - (str (if ?exported "1" "0") " " ?name " " ?ann)))) - (&/|interpose "\t") - (&/fold str ""))) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil - (->> imports (&/|interpose ";") (&/fold str ""))) - .visitEnd) - (.visitEnd))]] - (&&/save-class! name (.toByteArray =class))) - ?state) - - [["lux;Left" ?message]] - (fail* ?message))))))) + ;; (prn 'compile-module name) + (if (&&/cached? name) + (do ;; (println "YOLO") + (let [file-name (str "input/" name ".lux") + file-content (slurp file-name)] + (&&/load-cache name (hash file-content) compile-module))) + (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] + (&/map% compile-statement analysis+))] + (fn [state] + (if (->> state (&/get$ &/$MODULES) (&/|contains? name)) + (if (.equals ^Object name "lux") + (return* state nil) + (fail* "[Compiler Error] Can't redefine a module!")) + (let [file-name (str "input/" name ".lux") + file-content (slurp file-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (str name "/_") nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil (hash file-content)) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) + .visitEnd))] + (matchv ::M/objects [((&/exhaust% compiler-step) + (->> state + (&/set$ &/$SOURCE (&reader/from file-name file-content)) + (&/set$ &/$ENVS (&/|list (&/env name))) + (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %)) + (&/update$ &/$MODULES #(&/|put name &a-module/init-module %))))] + [["lux;Right" [?state _]]] + (&/run-state (|do [defs &a-module/defs + imports &a-module/imports + :let [_ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil + (->> defs + (&/|map (fn [_def] + (|let [[?exported ?name ?ann] _def] + (str (if ?exported "1" "0") " " ?name " " ?ann)))) + (&/|interpose "\t") + (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil + (->> imports (&/|interpose "\t") (&/fold str ""))) + .visitEnd) + (.visitEnd))]] + (&&/save-class! "_" (.toByteArray =class))) + ?state) + + [["lux;Left" ?message]] + (fail* ?message)))))))) + +(defn ^:private clean-file [^java.io.File file] + (if (.isDirectory file) + (do (doseq [f (seq (.listFiles file))] + (clean-file f)) + (.delete file)) + (.delete file))) + +(defn ^:private setup-dirs! [] + (.mkdir (java.io.File. "cache")) + (.mkdir (java.io.File. "cache/jvm")) + (.mkdir (java.io.File. "output")) + (.mkdir (java.io.File. "output/jvm")) + (doseq [f (seq (.listFiles (java.io.File. "output/jvm")))] + (clean-file f))) ;; [Resources] (defn compile-all [modules] - (.mkdir (java.io.File. "output")) + (setup-dirs!) (matchv ::M/objects [((&/map% compile-module (&/|cons "lux" modules)) (&/init-state nil))] [["lux;Right" [?state _]]] (println (str "Compilation complete! " (str "[" (->> modules diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 24f342469..7ac48e67e 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -1,40 +1,182 @@ (ns lux.compiler.base (:require [clojure.string :as string] + [clojure.java.io :as io] [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail*]]) - [lux.analyser.base :as &a]) + (lux [base :as & :refer [|do return* return fail fail*]] + [type :as &type]) + (lux.analyser [base :as &a] + [module :as &a-module])) (:import (org.objectweb.asm Opcodes Label ClassWriter MethodVisitor))) +;; [Utils] +(defn ^:private write-file [^String file ^bytes data] + (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))] + (.write stream data))) + +(defn ^:private write-output [module name data] + (let [module* module] + (.mkdirs (java.io.File. (str "output/jvm/" module*))) + (write-file (str "output/jvm/" module* "/" name ".class") data))) + +(defn ^:private write-cache [module name data] + (let [module* (string/replace module #"/" " ")] + (.mkdirs (java.io.File. (str "cache/jvm/" module*))) + (write-file (str "cache/jvm/" module* "/" name ".class") data))) + +(defn ^:private clean-file [^java.io.File file] + (if (.isDirectory file) + (do (doseq [f (seq (.listFiles file))] + (clean-file f)) + (.delete file)) + (.delete file))) + +(defn ^:private read-file [file] + (with-open [reader (io/input-stream file)] + (let [length (.length file) + buffer (byte-array length)] + (.read reader buffer 0 length) + buffer))) + ;; [Exports] +(def version "0.2") + (def local-prefix "l") (def partial-prefix "p") (def closure-prefix "c") (def apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") -;; (defn write-file [^String file ^bytes data] -;; (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))] -;; (.write stream data))) - -;; (defn write-class [name data] -;; (write-file (str "output/" name ".class") data)) - (defn load-class! [^ClassLoader loader name] (.loadClass loader name)) -;; (defn save-class! [name bytecode] -;; (|do [loader &/loader -;; :let [_ (write-class name bytecode) -;; _ (load-class! loader (string/replace name #"/" "."))]] -;; (return nil))) - (defn save-class! [name bytecode] - (let [real-name (string/replace name #"/" ".")] - (|do [loader &/loader - !classes &/classes - :let [_ (swap! !classes assoc real-name bytecode) - _ (load-class! loader real-name)]] - (return nil)))) + (|do [eval? &/get-eval + module &/get-module-name + loader &/loader + !classes &/classes + :let [real-name (str (string/replace module #"/" ".") "." name) + _ (swap! !classes assoc real-name bytecode) + _ (load-class! loader real-name) + _ (when (not eval?) + (do (write-output module name bytecode) + (write-cache module name bytecode)))]] + (return nil))) + +(defn cached? [module] + (.exists (java.io.File. (str "cache/jvm/" (string/replace module #"/" " ") "/_.class")))) + +(defn delete-cache [module] + (fn [state] + (do (clean-file (java.io.File. (str "cache/jvm/" (string/replace module #"/" " ")))) + (return* state nil)))) + +(defn ^:private replace-several [content & replacements] + (let [replacement-list (partition 2 replacements)] + (reduce #(try (let [[_pattern _rep] %2] + (string/replace %1 _pattern (string/re-quote-replacement _rep))) + (catch Exception e + (prn 'replace-several content %1 %2) + (throw e))) + content replacement-list))) + +(defn ^:private replace-cache [cache-name] + (if (.startsWith cache-name "$") + (replace-several cache-name + #"_ASTER_" "*" + #"_PLUS_" "+" + #"_DASH_" "-" + #"_SLASH_" "/" + #"_BSLASH_" "\\" + #"_UNDERS_" "_" + #"_PERCENT_" "%" + #"_DOLLAR_" "$" + #"_QUOTE_" "'" + #"_BQUOTE_" "`" + #"_AT_" "@" + #"_CARET_" "^" + #"_AMPERS_" "&" + #"_EQ_" "=" + #"_BANG_" "!" + #"_QM_" "?" + #"_COLON_" ":" + #"_PERIOD_" "." + #"_COMMA_" "," + #"_LT_" "<" + #"_GT_" ">" + #"_TILDE_" "~" + #"_PIPE_" "|") + cache-name)) + +(defn load-cache [module module-hash compile-module] + (|do [loader &/loader + !classes &/classes] + (let [module-path (str "cache/jvm/" (string/replace module #"/" " ")) + module* (string/replace module #"/" ".") + class-name (str module* "._") + module-meta (do (swap! !classes assoc class-name (read-file (java.io.File. (str module-path "/_.class")))) + (load-class! loader class-name))] + (if (and (= module-hash (-> module-meta (.getField "_hash") (.get nil))) + (= version (-> module-meta (.getField "_compiler") (.get nil)))) + (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") + ;; _ (prn module 'imports imports) + ] + (|do [loads (&/map% (fn [_import] + (load-cache _import (-> (str "input/" _import ".lux") slurp hash) compile-module)) + (if (= [""] imports) + (&/|list) + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (do (doseq [file (seq (.listFiles (java.io.File. module-path))) + :when (not= "_.class" (.getName file))] + (let [real-name (second (re-find #"^(.*)\.class$" (.getName file))) + bytecode (read-file file) + ;; _ (prn 'load-cache module real-name) + ] + ;; (swap! !classes assoc (str module* "." (replace-cache real-name)) bytecode) + (swap! !classes assoc (str module* "." real-name) bytecode) + ;; (swap! !classes assoc "__temp__" bytecode) + ;; (swap! !classes assoc (-> (load-class! loader "__temp__") (.getField "_name") (.get nil)) bytecode) + (write-output module real-name bytecode))) + ;; (swap! !classes dissoc "__temp__") + (let [defs (string/split (-> module-meta (.getField "_defs") (.get nil)) #"\t")] + (|do [_ (fn [state] + (&/run-state (&/map% (fn [_def] + (let [[_exported? _name _ann] (string/split _def #" ") + ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) + def-class (load-class! loader (str module* ".$" (&/normalize-ident _name))) + def-name (-> def-class (.getField "_name") (.get nil))] + (|do [_ (case _ann + "T" (&a-module/define module def-name (&/V "lux;TypeD" nil) &type/Type) + "M" (|do [_ (&a-module/define module def-name (&/V "lux;ValueD" &type/Macro) &type/Macro)] + (&a-module/declare-macro module def-name)) + "V" (let [def-type (-> def-class (.getField "_meta") (.get nil))] + (matchv ::M/objects [def-type] + [["lux;ValueD" _def-type]] + (&a-module/define module def-name def-type _def-type))) + ;; else + (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] + (|do [__type (&a-module/def-type __module __name)] + (do ;; (prn '__type [__module __name] (&type/show-type __type)) + (&a-module/def-alias module def-name __module __name __type)))))] + (if (= "1" _exported?) + (&a-module/export module def-name) + (return nil))) + )) + (if (= [""] defs) + (&/|list) + (&/->list defs))) + (->> state + (&/set$ &/$ENVS (&/|list (&/env module))) + (&/update$ &/$MODULES #(&/|put module &a-module/init-module %)))))] + (return true)))) + (|do [_ (delete-cache module) + _ (compile-module module)] + (return false))))) + + (|do [_ (delete-cache module) + _ (compile-module module)] + (return false))) + ))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index e825ca0ad..bc1ab23f1 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -319,46 +319,46 @@ 0))) (defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods] - (let [name* (&host/->class ?name) - super-class* (&host/->class ?super-class) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - name* nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) - _ (&/|map (fn [field] - (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) - (&host/->type-signature (:type field)) nil nil) - (.visitEnd))) - ?fields)] - (|do [_ (&/map% (fn [method] - (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" - (&host/->type-signature (:output method)))] - (&/with-writer (.visitMethod =class (modifiers->int (:modifiers method)) - (:name method) - signature nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (.visitCode =method)] - _ (compile (:body method)) - :let [_ (doto =method - (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) - ?methods)] - (&&/save-class! name* (.toByteArray (doto =class .visitEnd)))))) - -(defn compile-jvm-interface [compile ?name ?supers ?methods] - (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) - (let [name* (&host/->class ?name) - =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) - name* nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))) - _ (do (&/|map (fn [method] + (|do [module &/get-module-name] + (let [super-class* (&host/->class ?super-class) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (str module "/" ?name) nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) + (&host/->type-signature (:type field)) nil nil) + (.visitEnd))) + ?fields)] + (|do [_ (&/map% (fn [method] (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] - (.visitMethod =interface (modifiers->int (:modifiers method)) (:name method) signature nil nil))) - ?methods) - (.visitEnd =interface))] - (&&/save-class! name* (.toByteArray =interface)))) + (&/with-writer (.visitMethod =class (modifiers->int (:modifiers method)) + (:name method) + signature nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (.visitCode =method)] + _ (compile (:body method)) + :let [_ (doto =method + (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + ?methods)] + (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))))) + +(defn compile-jvm-interface [compile ?name ?supers ?methods] + ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) + (|do [module &/get-module-name] + (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) + (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))) + _ (do (&/|map (fn [method] + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (.visitMethod =interface (modifiers->int (:modifiers method)) (:name method) signature nil nil))) + ?methods) + (.visitEnd =interface))] + (&&/save-class! ?name (.toByteArray =interface))))) (defn compile-jvm-try [compile *type* ?body ?catches ?finally] (|do [^MethodVisitor *writer* &/get-writer diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 42ed5459e..7b08532fe 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -84,7 +84,8 @@ ;; [Exports] (defn compile-lambda [compile ?scope ?env ?body] - (|do [:let [lambda-class (&host/location ?scope) + ;; (prn 'compile-lambda (->> ?scope &/->seq)) + (|do [:let [lambda-class (str (&/|head ?scope) "/$" (&host/location (&/|tail ?scope))) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) lambda-class nil "java/lang/Object" (into-array ["lux/Function"])) @@ -99,5 +100,5 @@ )] _ (add-lambda-impl =class compile lambda-impl-signature ?body) :let [_ (.visitEnd =class)] - _ (&&/save-class! lambda-class (.toByteArray =class))] + _ (&&/save-class! (str "$" (&host/location (&/|tail ?scope))) (.toByteArray =class))] (instance-closure compile lambda-class ?env (lambda--signature ?env)))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index b47267d25..c8197da66 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -107,14 +107,14 @@ :let [_ (doto *writer* (.visitVarInsn Opcodes/ALOAD 0) (.visitFieldInsn Opcodes/GETFIELD - (&host/location ?scope) + (str (&/|head ?scope) "/$" (&host/location (&/|tail ?scope))) (str &&/closure-prefix ?captured-id) "Ljava/lang/Object;"))]] (return nil))) (defn compile-global [compile *type* ?owner-class ?name] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (&/|list ?owner-class ?name))) "_datum" "Ljava/lang/Object;")]] + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str ?owner-class "/$" (&/normalize-ident ?name)) "_datum" "Ljava/lang/Object;")]] (return nil))) (defn compile-apply [compile *type* ?fn ?arg] @@ -270,11 +270,13 @@ module-name &/get-module-name :let [outer-class (&host/->class module-name) datum-sig "Ljava/lang/Object;" - current-class (&host/location (&/|list outer-class ?name)) - _ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) + current-class (str outer-class "/" (str "$" (&/normalize-ident ?name))) + ;; _ (prn 'compile-def 'outer-class outer-class '?name ?name 'current-class current-class) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) current-class nil "java/lang/Object" (into-array ["lux/Function"])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_name" "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) (doto (.visitEnd))) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_meta" datum-sig nil nil) @@ -292,7 +294,7 @@ (.visitEnd))]] (return nil))) :let [_ (.visitEnd *writer*)] - _ (&&/save-class! current-class (.toByteArray =class))] + _ (&&/save-class! (str "$" (&/normalize-ident ?name)) (.toByteArray =class))] (return nil))) (defn compile-ann [compile *type* ?value-ex ?type-ex] diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 0e8c1b710..bef093247 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -124,7 +124,7 @@ (&/T (&/T file-name line-num column-num*) line))))) (&/V "No" (str "[Reader Error] Text failed: " text)))))) -(def ^:private ^String +source-dir+ "source/") +(def ^:private ^String +source-dir+ "input/") (defn from [^String file-name ^String file-content] (let [lines (&/->list (string/split-lines file-content)) file-name (.substring file-name (.length +source-dir+))] diff --git a/src/lux/type.clj b/src/lux/type.clj index d82eae8fd..e0315f8e7 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -169,7 +169,8 @@ (&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type))) (&/T "lux;host" HostState) (&/T "lux;seed" Int) - (&/T "lux;seen-sources" (&/V "lux;AppT" (&/T List Text)))))) + (&/T "lux;seen-sources" (&/V "lux;AppT" (&/T List Text))) + (&/T "lux;eval?" Bool)))) $Void))) (def Macro -- cgit v1.2.3 From e351122010b5eb5bf8793382a4a4ddcf5fb3a386 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 21 Jun 2015 01:30:27 -0400 Subject: - The backwards analysis of function application is back. --- input/lux.lux | 633 +++++++++++++++++++++-------------------------- src/lux/analyser/lux.clj | 200 +++++++-------- src/lux/compiler.clj | 4 +- src/lux/compiler/lux.clj | 9 +- 4 files changed, 390 insertions(+), 456 deletions(-) diff --git a/input/lux.lux b/input/lux.lux index 6c9a50f9d..282ca97b1 100644 --- a/input/lux.lux +++ b/input/lux.lux @@ -376,10 +376,9 @@ (_lux_lambda _ tokens (_lux_case tokens (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil]))) + (return (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) + (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + #Nil])) _ (fail "Wrong syntax for let'"))))) @@ -390,36 +389,34 @@ (_lux_lambda _ tokens (_lux_case tokens (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS ["" ""])) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS ["" ""])) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS self)) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS self)) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) _ (fail "Wrong syntax for lambda"))))) @@ -432,57 +429,53 @@ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + #Nil])) (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + #Nil])) _ (fail "Wrong syntax for def") @@ -493,53 +486,49 @@ Macro (_lux_case tokens (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def'"]) + (return (#Cons [($form (#Cons [($symbol ["lux" "def'"]) + (#Cons [($form (#Cons [name args])) + (#Cons [($symbol ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])) + (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])])) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) + (return (#Cons [($form (#Cons [($symbol ["lux" "def'"]) + (#Cons [($tag ["" "export"]) (#Cons [($form (#Cons [name args])) (#Cons [($symbol ["lux" "Macro"]) (#Cons [body #Nil])]) - ])])) - (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])]))) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (#Cons [($form (#Cons [($symbol ["lux" "def'"]) - (#Cons [($tag ["" "export"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])])) - (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])]))) + ])])])) + (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])])) _ (fail "Wrong syntax for defmacro"))) (_lux_declare-macro defmacro) (defmacro #export (comment tokens) - (return (_lux_: SyntaxList #Nil))) + (return #Nil)) (defmacro (->' tokens) (_lux_case tokens (#Cons [input (#Cons [output #Nil])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil])) (#Cons [input (#Cons [output others])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) + #Nil])) _ (fail "Wrong syntax for ->'"))) @@ -548,24 +537,22 @@ (_lux_case tokens (#Cons [(#Meta [_ (#TupleS #Nil)]) (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (#Cons [body - #Nil]))) + (return (#Cons [body + #Nil])) (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) - (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) - (#Cons [(_meta (#TextS "")) - (#Cons [(_meta (#TextS arg-name)) - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) - (#Cons [(_meta (#TupleS other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) + (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) + (#Cons [(_meta (#TextS "")) + (#Cons [(_meta (#TextS arg-name)) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) + (#Cons [(_meta (#TupleS other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) + #Nil])) _ (fail "Wrong syntax for All'"))) @@ -574,11 +561,10 @@ (_lux_case tokens (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) #Nil]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) - (#Cons [(_meta (#TextS bound-name)) - #Nil])]))) - #Nil]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) + (#Cons [(_meta (#TextS bound-name)) + #Nil])]))) + #Nil])) _ (fail "Wrong syntax for B'"))) @@ -589,13 +575,12 @@ (return tokens) (#Cons [x (#Cons [y xs])]) - (return (_lux_: SyntaxList - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) - (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil]))) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) + (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) + #Nil])) _ (fail "Wrong syntax for $'"))) @@ -629,32 +614,27 @@ (def' #export (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) - (foldL (_lux_: (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda' [tail head] - (#Cons [head tail]))) + (foldL (lambda' [tail head] (#Cons [head tail])) #Nil list)) (defmacro #export (list xs) - (return (_lux_: SyntaxList - (#Cons [(foldL (lambda' [tail head] - (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) - (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) - (_meta (#TagS ["lux" "Nil"])) - (reverse xs)) - #Nil])))) + (return (#Cons [(foldL (lambda' [tail head] + (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) + (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) + (_meta (#TagS ["lux" "Nil"])) + (reverse xs)) + #Nil]))) (defmacro #export (list& xs) (_lux_case (reverse xs) (#Cons [last init]) - (return (_lux_: SyntaxList - (list (foldL (lambda' [tail head] - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list head tail))))))) - last - init)))) + (return (list (foldL (lambda' [tail head] + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) + last + init))) _ (fail "Wrong syntax for list&"))) @@ -674,17 +654,16 @@ (fail "lambda requires a non-empty arguments tuple.") (#Cons [harg targs]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol name) - harg - (foldL (lambda' [body' arg] - ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol ["" ""]) - arg - body'))) - body - (reverse targs)))))))) + (return (list ($form (list ($symbol ["" "_lux_lambda"]) + ($symbol name) + harg + (foldL (lambda' [body' arg] + ($form (list ($symbol ["" "_lux_lambda"]) + ($symbol ["" ""]) + arg + body'))) + body + (reverse targs))))))) _ (fail "Wrong syntax for lambda")))) @@ -694,43 +673,39 @@ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body)))))) - ($form (list ($symbol ["" "_lux_export"]) name))))) + (return (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))) + ($form (list ($symbol ["" "_lux_export"]) name)))) (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - body)))) - ($form (list ($symbol ["" "_lux_export"]) name))))) + (return (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + body)))) + ($form (list ($symbol ["" "_lux_export"]) name)))) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) - type - ($form (list ($symbol ["lux" "lambda"]) - name - ($tuple args) - body))))))))) + (return (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) + type + ($form (list ($symbol ["lux" "lambda"]) + name + ($tuple args) + body)))))))) (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (_lux_: SyntaxList - (list ($form (list ($symbol ["" "_lux_def"]) - name - ($form (list ($symbol ["" "_lux_:"]) type body))))))) + (return (list ($form (list ($symbol ["" "_lux_def"]) + name + ($form (list ($symbol ["" "_lux_:"]) type body)))))) _ (fail "Wrong syntax for def") @@ -749,19 +724,16 @@ (defmacro #export (let tokens) (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) - (return (_lux_: SyntaxList - (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (_lux_case binding - [label value] - (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) - body - (foldL (_lux_: (All' [a] - (->' ($' List (B' a)) (B' a) ($' List (B' a)))) - (lambda [tail head] (#Cons [head tail]))) - #Nil - (as-pairs bindings)))))) + (return (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (_lux_case binding + [label value] + (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) + body + (foldL (lambda [tail head] (#Cons [head tail])) + #Nil + (as-pairs bindings))))) _ (fail "Wrong syntax for let"))) @@ -825,10 +797,9 @@ (defmacro #export ($ tokens) (_lux_case tokens (#Cons [op (#Cons [init args])]) - (return (_lux_: SyntaxList - (list (foldL (lambda [a1 a2] ($form (list op a1 a2))) - init - args)))) + (return (list (foldL (lambda [a1 a2] ($form (list op a1 a2))) + init + args))) _ (fail "Wrong syntax for $"))) @@ -837,16 +808,15 @@ (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) (_lux_case (any? spliced? elems) true - (let [elems' (map (_lux_: (->' Syntax Syntax) - (lambda [elem] - (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced + (let [elems' (map (lambda [elem] + (_lux_case elem + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced - _ - ($form (list ($symbol ["" "_lux_:"]) - ($symbol ["lux" "SyntaxList"]) - ($form (list ($symbol ["lux" "list"]) (untemplate elem)))))))) + _ + ($form (list ($symbol ["" "_lux_:"]) + ($symbol ["lux" "SyntaxList"]) + ($form (list ($symbol ["lux" "list"]) (untemplate elem))))))) elems)] (wrap-meta ($form (list tag ($form (list& ($symbol ["lux" "$"]) @@ -913,8 +883,7 @@ (defmacro (`' tokens) (_lux_case tokens (#Cons [template #Nil]) - (return (_lux_: SyntaxList - (list (untemplate "" template)))) + (return (list (untemplate "" template))) _ (fail "Wrong syntax for `'"))) @@ -922,17 +891,15 @@ (defmacro #export (|> tokens) (_lux_case tokens (#Cons [init apps]) - (return (_lux_: SyntaxList - (list (foldL (_lux_: (->' Syntax Syntax Syntax) - (lambda [acc app] - (_lux_case app - (#Meta [_ (#FormS parts)]) - ($form (list:++ parts (list acc))) - - _ - (`' ((~ app) (~ acc)))))) - init - apps)))) + (return (list (foldL (lambda [acc app] + (_lux_case app + (#Meta [_ (#FormS parts)]) + ($form (list:++ parts (list acc))) + + _ + (`' ((~ app) (~ acc))))) + init + apps))) _ (fail "Wrong syntax for |>"))) @@ -940,10 +907,9 @@ (defmacro #export (if tokens) (_lux_case tokens (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (_lux_: SyntaxList - (list (`' (_lux_case (~ test) - true (~ then) - false (~ else)))))) + (return (list (`' (_lux_case (~ test) + true (~ then) + false (~ else))))) _ (fail "Wrong syntax for if"))) @@ -1000,8 +966,7 @@ (defmacro #export (^ tokens) (_lux_case tokens (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) - (return (_lux_: SyntaxList - (list (`' (#;DataT (~ (_meta (#TextS class-name)))))))) + (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) _ (fail "Wrong syntax for ^"))) @@ -1009,18 +974,15 @@ (defmacro #export (-> tokens) (_lux_case (reverse tokens) (#Cons [output inputs]) - (return (_lux_: SyntaxList - (list (foldL (_lux_: (->' Syntax Syntax Syntax) - (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))) - output - inputs)))) + (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) + output + inputs))) _ (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) - (return (_lux_: SyntaxList - (list (`' (#;TupleT (;list (~@ tokens)))))))) + (return (list (`' (#;TupleT (;list (~@ tokens))))))) (defmacro (do tokens) (_lux_case tokens @@ -1039,10 +1001,9 @@ (~ value))))))) body (reverse (as-pairs bindings)))] - (return (_lux_: SyntaxList - (list (`' (_lux_case (~ monad) - {#;return ;return #;bind ;bind} - (~ body'))))))) + (return (list (`' (_lux_case (~ monad) + {#;return ;return #;bind ;bind} + (~ body')))))) _ (fail "Wrong syntax for do"))) @@ -1058,13 +1019,13 @@ (let [{#;return ;return #;bind _} m] (_lux_case xs #Nil - (;return (_lux_: List #Nil)) + (;return #Nil) (#Cons [x xs']) (do m [y (f x) ys (map% m f xs')] - (;return (_lux_: List (#Cons [y ys])))) + (;return (#Cons [y ys]))) ))) (def'' #export (. f g) @@ -1271,20 +1232,17 @@ (#Some idents) (_lux_case idents #Nil - (return (_lux_: SyntaxList - (list body))) + (return (list body)) (#Cons [harg targs]) (let [replacements (map (_lux_: (-> Text (, Text Syntax)) (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) (list& self-ident idents)) - body' (foldL (_lux_: (-> Syntax Text Syntax) - (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) + body' (foldL (lambda [body' arg'] + (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))) (replace-syntax replacements body) (reverse targs))] - (return (_lux_: SyntaxList - (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')]))))))) + (return (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))) #None (fail "'All' arguments must be symbols.")) @@ -1377,18 +1335,17 @@ (#Meta [_ (#TagS ident)]) (do Lux:Monad [ident (normalize ident)] - (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (;,)])))) + (;return (`' [(~ ($text (ident->text ident))) (;,)]))) (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) (do Lux:Monad [ident (normalize ident)] - (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) _ (fail "Wrong syntax for |")))) tokens)] - (;return (_lux_: SyntaxList - (list (`' (#;VariantT (;list (~@ pairs))))))))) + (;return (list (`' (#;VariantT (;list (~@ pairs)))))))) (defmacro #export (& tokens) (if (not (multiple? 2 (length tokens))) @@ -1401,13 +1358,12 @@ [(#Meta [_ (#TagS ident)]) value] (do Lux:Monad [ident (normalize ident)] - (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) _ (fail "Wrong syntax for &")))) (as-pairs tokens))] - (;return (_lux_: SyntaxList - (list (`' (#;RecordT (;list (~@ pairs)))))))))) + (;return (list (`' (#;RecordT (;list (~@ pairs))))))))) (def'' #export (->text x) (-> (^ java.lang.Object) Text) @@ -1474,32 +1430,32 @@ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux:Monad [macro-name' (normalize macro-name) - ?macro (find-macro (_lux_: Ident macro-name'))] - (_lux_case (_lux_: ($' Maybe Macro) ?macro) + ?macro (find-macro macro-name')] + (_lux_case ?macro (#Some macro) (do Lux:Monad [expansion (macro args) - expansion' (map% Lux:Monad macro-expand (_lux_: SyntaxList expansion))] - (;return (_lux_: SyntaxList (list:join (_lux_: ($' List SyntaxList) expansion'))))) + expansion' (map% Lux:Monad macro-expand expansion)] + (;return (list:join expansion'))) #None (do Lux:Monad [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] - (;return (_lux_: SyntaxList (list ($form (list:join (_lux_: ($' List SyntaxList) parts'))))))))) + (;return (list ($form (list:join parts'))))))) (#Meta [_ (#FormS (#Cons [harg targs]))]) (do Lux:Monad [harg+ (macro-expand harg) - targs+ (map% Lux:Monad macro-expand (_lux_: SyntaxList targs))] - (;return (_lux_: SyntaxList (list ($form (list:++ harg+ (list:join (_lux_: ($' List SyntaxList) targs+)))))))) + targs+ (map% Lux:Monad macro-expand targs)] + (;return (list ($form (list:++ harg+ (list:join targs+)))))) (#Meta [_ (#TupleS members)]) (do Lux:Monad [members' (map% Lux:Monad macro-expand members)] - (;return (_lux_: SyntaxList (list ($tuple (list:join (_lux_: ($' List SyntaxList) members'))))))) + (;return (list ($tuple (list:join members'))))) _ - (return (_lux_: SyntaxList (list syntax))))) + (return (list syntax)))) (def'' (walk-type type) (-> Syntax Syntax) @@ -1511,8 +1467,7 @@ ($tuple (map walk-type members)) (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (foldL (_lux_: (-> Syntax Syntax Syntax) - (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) + (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) (walk-type type-fn) (map walk-type args)) @@ -1524,10 +1479,9 @@ (#Cons [type #Nil]) (do Lux:Monad [type+ (macro-expand type)] - (_lux_case (_lux_: SyntaxList type+) + (_lux_case type+ (#Cons [type' #Nil]) - (;return (_lux_: SyntaxList - (list (walk-type type')))) + (;return (list (walk-type type'))) _ (fail "type`: The expansion of the type-syntax had to yield a single element."))) @@ -1538,8 +1492,7 @@ (defmacro #export (: tokens) (_lux_case tokens (#Cons [type (#Cons [value #Nil])]) - (return (_lux_: SyntaxList - (list (`' (_lux_: (;type` (~ type)) (~ value)))))) + (return (list (`' (_lux_: (;type` (~ type)) (~ value))))) _ (fail "Wrong syntax for :"))) @@ -1547,8 +1500,7 @@ (defmacro #export (:! tokens) (_lux_case tokens (#Cons [type (#Cons [value #Nil])]) - (return (: (List Syntax) - (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) + (return (list (`' (_lux_:! (;type` (~ type)) (~ value))))) _ (fail "Wrong syntax for :!"))) @@ -1584,9 +1536,8 @@ _ (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (: (List Syntax) - (list& (`' (_lux_def (~ name) (;type` (~ type')))) - with-export)))) + (return (list& (`' (_lux_def (~ name) (;type` (~ type')))) + with-export))) #None (fail "Wrong syntax for deftype")) @@ -1599,8 +1550,7 @@ (_lux_case tokens (#Cons [value #Nil]) (let [blank ($symbol ["" ""])] - (return (_lux_: SyntaxList - (list (`' (_lux_lambda (~ blank) (~ blank) (~ value))))))) + (return (list (`' (_lux_lambda (~ blank) (~ blank) (~ value)))))) _ (fail "Wrong syntax for io"))) @@ -1609,11 +1559,9 @@ (_lux_case (reverse tokens) (#Cons [value actions]) (let [dummy ($symbol ["" ""])] - (return (_lux_: SyntaxList - (list (foldL (: (-> Syntax Syntax Syntax) - (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) - value - actions))))) + (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) + value + actions)))) _ (fail "Wrong syntax for exec"))) @@ -1658,11 +1606,10 @@ #None body'))] - (return (: (List Syntax) - (list& (`' (_lux_def (~ name) (~ body''))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) + (return (list& (`' (_lux_def (~ name) (~ body''))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) #None (fail "Wrong syntax for def")))) @@ -1684,16 +1631,14 @@ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) (do Lux:Monad [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args))) - expansions (map% Lux:Monad expander (as-pairs (: (List Syntax) expansion)))] - (;return (: (List (, Syntax Syntax)) (list:join (: (List (List (, Syntax Syntax))) expansions))))) + expansions (map% Lux:Monad expander (as-pairs expansion))] + (;return (list:join expansions))) _ - (;return (: (List (, Syntax Syntax)) (list branch))))))) + (;return (list branch)))))) (as-pairs branches))] - (;return (_lux_: SyntaxList - (list (`' (_lux_case (~ value) - (~@ (|> (: (List (List (, Syntax Syntax))) expansions) - list:join (map rejoin-pair) list:join)))))))) + (;return (list (`' (_lux_case (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) _ (fail "Wrong syntax for case"))) @@ -1703,10 +1648,9 @@ (#Cons [body (#Cons [pattern #Nil])]) (do Lux:Monad [pattern+ (macro-expand pattern)] - (case (: (List Syntax) pattern+) + (case pattern+ (#Cons [pattern' #Nil]) - (;return (: (List Syntax) - (list pattern' body))) + (;return (list pattern' body)) _ (fail "\\ can only expand to 1 pattern."))) @@ -1724,10 +1668,8 @@ _ (do Lux:Monad [patterns' (map% Lux:Monad macro-expand patterns)] - (;return (: (List Syntax) - (list:join (map (: (-> Syntax (List Syntax)) - (lambda [pattern] (list pattern body))) - (list:join patterns'))))))) + (;return (list:join (map (lambda [pattern] (list pattern body)) + (list:join patterns')))))) _ (fail "Wrong syntax for \\or"))) @@ -1748,8 +1690,7 @@ [module-name get-module-name] (case tokens (\ (list template)) - (;return (_lux_: SyntaxList - (list (untemplate module-name template)))) + (;return (list (untemplate module-name template))) _ (fail "Wrong syntax for `")))) @@ -1769,7 +1710,7 @@ (-> Syntax (Lux Syntax)) (do Lux:Monad [token+ (macro-expand token)] - (case (: (List Syntax) token+) + (case token+ (\ (list token')) (;return token') @@ -1791,13 +1732,12 @@ _ (fail "Signatures require typed members!")))) tokens')] - (;return (: (List Syntax) - (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) - (lambda [pair] - (let [[name type] pair] - (`' [(~ (|> name ident->text $text)) - (~ type)])))) - members)))))))))) + (;return (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) + (lambda [pair] + (let [[name type] pair] + (`' [(~ (|> name ident->text $text)) + (~ type)])))) + members))))))))) (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1826,11 +1766,10 @@ _ (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (: (List Syntax) - (list& (`' (_lux_def (~ name) (~ sigs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) + (return (list& (`' (_lux_def (~ name) (~ sigs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) #None (fail "Wrong syntax for defsig")))) @@ -1850,8 +1789,7 @@ _ (fail "Structures require defined members!")))) tokens')] - (;return (: (List Syntax) - (list ($record members)))))) + (;return (list ($record members))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1880,11 +1818,10 @@ _ (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (: (List Syntax) - (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil))))) + (return (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) #None (fail "Wrong syntax for defsig")))) @@ -1933,11 +1870,9 @@ [(defmacro #export ( tokens) (case (reverse tokens) (\ (list& last init)) - (return (: (List Syntax) - (list (foldL (: (-> Syntax Syntax Syntax) - (lambda [post pre] (` ))) - last - init)))) + (return (list (foldL (lambda [post pre] (` )) + last + init))) _ (fail )))] @@ -1982,11 +1917,9 @@ (list))))) (let [{#module-aliases _ #defs defs #imports _} lux] defs))] - (#Right [state (: (List Syntax) - (map (: (-> Text Syntax) - (lambda [name] - (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) - (list:join to-alias)))])) + (#Right [state (map (lambda [name] + (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name]))))) + (list:join to-alias))])) #None (#Left "Uh, oh... The universe is not working properly...")) @@ -2091,19 +2024,17 @@ [module name] (split-slot sname)] [($tag [module name]) ($symbol ["" name])]))) slots))] - (#Right [state (: (List Syntax) - (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) + (#Right [state (list (` (_lux_case (~ struct) (~ pattern) (~ body))))])) _ (#Left "Can only \"use\" records.")))))) _ (let [dummy ($symbol ["" ""])] - (#Right [state (: (List Syntax) - (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) - (~ body))))))]))) + (#Right [state (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) + (~ body)))))]))) _ (#Left "Wrong syntax for defsig"))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 90811c77e..6bbcd0fcf 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -115,112 +115,110 @@ ;; [?module ?name] ;; [(if (.equals "" ?module) module-name ?module) ;; ?name]) - ((|do [[[r-module r-name] $def] (&&module/find-def (if (.equals "" ?module) module-name ?module) - ?name) - ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state)) + ((|do [[[r-module r-name] $def] (&&module/find-def (if (.equals "" ?module) module-name ?module) + ?name) + ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" ?type]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state)) [["lux;Cons" [?genv ["lux;Nil" _]]]] (do ;; (prn 'analyse-symbol/_2 ?module ?name local-ident (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] - (do ;; (prn 'analyse-symbol/_2.1 ?module ?name local-ident (aget global 0)) - (matchv ::M/objects [global] - [[["lux;Global" [?module* ?name*]] _]] - ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) - ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) - - [_] - (do ;; (prn 'analyse-symbol/_2.1.2 ?module ?name local-ident) - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) - (fail* "_{_ analyse-symbol _}_"))) + (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] + (do ;; (prn 'analyse-symbol/_2.1 ?module ?name local-ident (aget global 0)) + (matchv ::M/objects [global] + [[["lux;Global" [?module* ?name*]] _]] + ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) + ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" ?type]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state) + + [_] + (do ;; (prn 'analyse-symbol/_2.1.2 ?module ?name local-ident) + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) + (fail* "_{_ analyse-symbol _}_"))) [["lux;Cons" [top-outer _]]] (do ;; (prn 'analyse-symbol/_3 ?module ?name) - (|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) ident register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) - (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) - (&/|list)) - (&/|reverse inner) scopes)] - ((|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] - (return (&/|list =local))) - (&/set$ &/$ENVS (&/|++ inner* outer) state)))) + (|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) ident register frame)] + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) + (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) + (&/|list)) + (&/|reverse inner) scopes)] + ((|do [btype (&&/expr-type =local) + _ (&type/check exo-type btype)] + (return (&/|list =local))) + (&/set$ &/$ENVS (&/|++ inner* outer) state)))) ))) )) -(defn ^:private analyse-apply* [analyse exo-type =fn ?args] - (matchv ::M/objects [=fn] - [[?fun-expr ?fun-type]] - (matchv ::M/objects [?args] - [["lux;Nil" _]] - (|do [_ (&type/check exo-type ?fun-type)] - (return =fn)) - - [["lux;Cons" [?arg ?args*]]] - (|do [?fun-type* (&type/actual-type ?fun-type)] - (matchv ::M/objects [?fun-type*] - [["lux;AllT" _]] - (&type/with-var - (fn [$var] - (|do [type* (&type/apply-type ?fun-type* $var) - output (analyse-apply* analyse exo-type (&/T ?fun-expr type*) ?args)] - (matchv ::M/objects [output $var] - [[?expr* ?type*] ["lux;VarT" ?id]] - (|do [? (&type/bound? ?id) - _ (if ? - (return nil) - (|do [ex &type/existential] - (&type/set-var ?id ex))) - type** (&type/clean $var ?type*)] - (return (&/T ?expr* type**))) - )))) - - [["lux;LambdaT" [?input-t ?output-t]]] - (|do [=arg (&&/analyse-1 analyse ?input-t ?arg)] - (analyse-apply* analyse exo-type (&/T (&/V "apply" (&/T =fn =arg)) - ?output-t) - ?args*)) +(defn ^:private analyse-apply* [analyse exo-type fun-type ?args] + ;; (prn 'analyse-apply* (aget fun-type 0)) + (matchv ::M/objects [?args] + [["lux;Nil" _]] + (|do [_ (&type/check exo-type fun-type)] + (return (&/T fun-type (&/|list)))) + + [["lux;Cons" [?arg ?args*]]] + (|do [?fun-type* (&type/actual-type fun-type)] + (matchv ::M/objects [?fun-type*] + [["lux;AllT" _]] + (&type/with-var + (fn [$var] + (|do [type* (&type/apply-type ?fun-type* $var) + [=output-t =args] (analyse-apply* analyse exo-type type* ?args)] + (matchv ::M/objects [$var] + [["lux;VarT" ?id]] + (|do [? (&type/bound? ?id) + _ (if ? + (return nil) + (|do [ex &type/existential] + (&type/set-var ?id ex))) + type** (&type/clean $var =output-t)] + (return (&/T type** =args))) + )))) + + [["lux;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)))) - [_] - (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) - ))) + [_] + (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) + )) (defn analyse-apply [analyse exo-type =fn ?args] (|do [loader &/loader] @@ -235,12 +233,14 @@ (&/flat-map% (partial analyse exo-type) macro-expansion)) [_] - (|do [output (analyse-apply* analyse exo-type =fn ?args)] - (return (&/|list output))))) + (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] + (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) + =output-t)))))) [_] - (|do [output (analyse-apply* analyse exo-type =fn ?args)] - (return (&/|list output)))) + (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] + (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) + =output-t))))) ))) (defn analyse-case [analyse exo-type ?value ?branches] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index d88c33437..1970c548a 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -60,8 +60,8 @@ [["lux;Global" [?owner-class ?name]]] (&&lux/compile-global compile-expression ?type ?owner-class ?name) - [["apply" [?fn ?arg]]] - (&&lux/compile-apply compile-expression ?type ?fn ?arg) + [["apply" [?fn ?args]]] + (&&lux/compile-apply compile-expression ?type ?fn ?args) [["variant" [?tag ?members]]] (&&lux/compile-variant compile-expression ?type ?tag ?members) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index c8197da66..ecb614732 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -117,11 +117,14 @@ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str ?owner-class "/$" (&/normalize-ident ?name)) "_datum" "Ljava/lang/Object;")]] (return nil))) -(defn compile-apply [compile *type* ?fn ?arg] +(defn compile-apply [compile *type* ?fn ?args] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?fn) - _ (compile ?arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature)]] + _ (&/map% (fn [?arg] + (|do [=arg (compile ?arg) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature)]] + (return =arg))) + ?args)] (return nil))) (defn ^:private type->analysis [type] -- cgit v1.2.3 From 658ff3e1e7d90ce72c8a02ef4cf7e177d8ac6f86 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 12 Jul 2015 21:04:56 -0400 Subject: - Added the beginnings of the standard library. - Fixed several bugs. --- input/lux.lux | 1400 +++++++++++++++++++++++++++++------------ input/lux/codata/stream.lux | 63 ++ input/lux/control/comonad.lux | 54 ++ input/lux/control/functor.lux | 35 ++ input/lux/control/lazy.lux | 47 ++ input/lux/control/monad.lux | 107 ++++ input/lux/control/monoid.lux | 57 ++ input/lux/data/bounded.lux | 26 + input/lux/data/dict.lux | 83 +++ input/lux/data/eq.lux | 35 ++ input/lux/data/io.lux | 51 ++ input/lux/data/list.lux | 218 +++++++ input/lux/data/number.lux | 64 ++ input/lux/data/ord.lux | 56 ++ input/lux/data/show.lux | 27 + input/lux/data/state.lux | 13 + input/lux/data/text.lux | 139 ++++ input/lux/meta/lux.lux | 185 ++++++ input/lux/meta/macro.lux | 54 ++ input/lux/meta/syntax.lux | 237 +++++++ input/program.lux | 39 +- src/lux/analyser.clj | 32 +- src/lux/analyser/case.clj | 11 +- src/lux/analyser/env.clj | 16 +- src/lux/analyser/host.clj | 9 +- src/lux/analyser/lux.clj | 109 +++- src/lux/analyser/module.clj | 79 +-- src/lux/base.clj | 14 +- src/lux/compiler.clj | 2 +- src/lux/compiler/host.clj | 27 +- src/lux/compiler/lux.clj | 13 +- src/lux/lexer.clj | 20 +- src/lux/type.clj | 37 +- 33 files changed, 2825 insertions(+), 534 deletions(-) create mode 100644 input/lux/codata/stream.lux create mode 100644 input/lux/control/comonad.lux create mode 100644 input/lux/control/functor.lux create mode 100644 input/lux/control/lazy.lux create mode 100644 input/lux/control/monad.lux create mode 100644 input/lux/control/monoid.lux create mode 100644 input/lux/data/bounded.lux create mode 100644 input/lux/data/dict.lux create mode 100644 input/lux/data/eq.lux create mode 100644 input/lux/data/io.lux create mode 100644 input/lux/data/list.lux create mode 100644 input/lux/data/number.lux create mode 100644 input/lux/data/ord.lux create mode 100644 input/lux/data/show.lux create mode 100644 input/lux/data/state.lux create mode 100644 input/lux/data/text.lux create mode 100644 input/lux/meta/lux.lux create mode 100644 input/lux/meta/macro.lux create mode 100644 input/lux/meta/syntax.lux diff --git a/input/lux.lux b/input/lux.lux index 282ca97b1..de407bafe 100644 --- a/input/lux.lux +++ b/input/lux.lux @@ -126,6 +126,7 @@ ## (, Text Int Int)) (_lux_def Cursor (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) +(_lux_export Cursor) ## (deftype (Meta m v) ## (| (#Meta (, m v)))) @@ -234,6 +235,7 @@ (#Cons [["lux;MacroD" (#BoundT "")] (#Cons [["lux;AliasD" Ident] #Nil])])])]))])) +(_lux_export DefData') ## (deftype LuxVar ## (| (#Local Int) @@ -341,32 +343,32 @@ (_lux_lambda _ state (#Left msg))))) -(_lux_def $text +(_lux_def text$ (_lux_: (#LambdaT [Text Syntax]) (_lux_lambda _ text (_meta (#TextS text))))) -(_lux_def $symbol +(_lux_def symbol$ (_lux_: (#LambdaT [Ident Syntax]) (_lux_lambda _ ident (_meta (#SymbolS ident))))) -(_lux_def $tag +(_lux_def tag$ (_lux_: (#LambdaT [Ident Syntax]) (_lux_lambda _ ident (_meta (#TagS ident))))) -(_lux_def $form +(_lux_def form$ (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) (_lux_lambda _ tokens (_meta (#FormS tokens))))) -(_lux_def $tuple +(_lux_def tuple$ (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) (_lux_lambda _ tokens (_meta (#TupleS tokens))))) -(_lux_def $record +(_lux_def record$ (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) (_lux_lambda _ tokens (_meta (#RecordS tokens))))) @@ -376,7 +378,7 @@ (_lux_lambda _ tokens (_lux_case tokens (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) + (return (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_case"]) (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) #Nil])) @@ -439,7 +441,7 @@ (#Cons [body #Nil])])])]))) #Nil])])]))) #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) @@ -450,7 +452,7 @@ (#Cons [body #Nil])])]))) #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) @@ -482,28 +484,28 @@ )))) (_lux_declare-macro def') -(def' #export (defmacro tokens) +(def' (defmacro tokens) Macro (_lux_case tokens (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (#Cons [($form (#Cons [($symbol ["lux" "def'"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (#Cons [(form$ (#Cons [name args])) + (#Cons [(symbol$ ["lux" "Macro"]) (#Cons [body #Nil])]) ])])) - (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #Nil])])) (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (#Cons [($form (#Cons [($symbol ["lux" "def'"]) - (#Cons [($tag ["" "export"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (#Cons [(tag$ ["" "export"]) + (#Cons [(form$ (#Cons [name args])) + (#Cons [(symbol$ ["lux" "Macro"]) (#Cons [body #Nil])]) ])])])) - (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #Nil])])) _ @@ -585,7 +587,7 @@ _ (fail "Wrong syntax for $'"))) -(def' #export (foldL f init xs) +(def' (foldL f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) @@ -598,27 +600,14 @@ (#Cons [x xs']) (foldL f (f init x) xs'))) -(def' #export (foldR f init xs) - (All' [a b] - (->' (->' (B' b) (B' a) (B' a)) - (B' a) - ($' List (B' b)) - (B' a))) - (_lux_case xs - #Nil - init - - (#Cons [x xs']) - (f x (foldR f init xs')))) - -(def' #export (reverse list) +(def' (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) (foldL (lambda' [tail head] (#Cons [head tail])) #Nil list)) -(defmacro #export (list xs) +(defmacro (list xs) (return (#Cons [(foldL (lambda' [tail head] (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) @@ -627,7 +616,7 @@ (reverse xs)) #Nil]))) -(defmacro #export (list& xs) +(defmacro (list& xs) (_lux_case (reverse xs) (#Cons [last init]) (return (list (foldL (lambda' [tail head] @@ -654,12 +643,12 @@ (fail "lambda requires a non-empty arguments tuple.") (#Cons [harg targs]) - (return (list ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol name) + (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ name) harg (foldL (lambda' [body' arg] - ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol ["" ""]) + (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" ""]) arg body'))) body @@ -673,39 +662,39 @@ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) name - ($form (list ($symbol ["" "_lux_:"]) + (form$ (list (symbol$ ["" "_lux_:"]) type - ($form (list ($symbol ["lux" "lambda"]) + (form$ (list (symbol$ ["lux" "lambda"]) name - ($tuple args) + (tuple$ args) body)))))) - ($form (list ($symbol ["" "_lux_export"]) name)))) + (form$ (list (symbol$ ["" "_lux_export"]) name)))) (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) name - ($form (list ($symbol ["" "_lux_:"]) + (form$ (list (symbol$ ["" "_lux_:"]) type body)))) - ($form (list ($symbol ["" "_lux_export"]) name)))) + (form$ (list (symbol$ ["" "_lux_export"]) name)))) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) name - ($form (list ($symbol ["" "_lux_:"]) + (form$ (list (symbol$ ["" "_lux_:"]) type - ($form (list ($symbol ["lux" "lambda"]) + (form$ (list (symbol$ ["lux" "lambda"]) name - ($tuple args) + (tuple$ args) body)))))))) (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) name - ($form (list ($symbol ["" "_lux_:"]) type body)))))) + (form$ (list (symbol$ ["" "_lux_:"]) type body)))))) _ (fail "Wrong syntax for def") @@ -729,16 +718,14 @@ (lambda [body binding] (_lux_case binding [label value] - (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) + (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) body - (foldL (lambda [tail head] (#Cons [head tail])) - #Nil - (as-pairs bindings))))) + (reverse (as-pairs bindings))))) _ (fail "Wrong syntax for let"))) -(def'' #export (map f xs) +(def'' (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs @@ -748,7 +735,7 @@ (#Cons [x xs']) (#Cons [(f x) (map f xs')]))) -(def'' #export (any? p xs) +(def'' (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) (_lux_case xs @@ -785,7 +772,7 @@ (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) (_meta (#TupleS (list token (untemplate-list tokens'))))))))) -(def'' (list:++ xs ys) +(def'' #export (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) (_lux_case xs (#Cons [x xs']) @@ -797,7 +784,7 @@ (defmacro #export ($ tokens) (_lux_case tokens (#Cons [op (#Cons [init args])]) - (return (list (foldL (lambda [a1 a2] ($form (list op a1 a2))) + (return (list (foldL (lambda [a1 a2] (form$ (list op a1 a2))) init args))) @@ -814,35 +801,36 @@ spliced _ - ($form (list ($symbol ["" "_lux_:"]) - ($symbol ["lux" "SyntaxList"]) - ($form (list ($symbol ["lux" "list"]) (untemplate elem))))))) + (form$ (list (symbol$ ["" "_lux_:"]) + (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) + (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) + (tag$ ["lux" "Nil"]))))))))) elems)] - (wrap-meta ($form (list tag - ($form (list& ($symbol ["lux" "$"]) - ($symbol ["lux" "list:++"]) + (wrap-meta (form$ (list tag + (form$ (list& (symbol$ ["lux" "$"]) + (symbol$ ["lux" "list:++"]) elems')))))) false - (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) + (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) (def'' (untemplate subst token) (->' Text Syntax Syntax) (_lux_case token (#Meta [_ (#BoolS value)]) - (wrap-meta ($form (list ($tag ["lux" "BoolS"]) (_meta (#BoolS value))))) + (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) (#Meta [_ (#IntS value)]) - (wrap-meta ($form (list ($tag ["lux" "IntS"]) (_meta (#IntS value))))) + (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) (#Meta [_ (#RealS value)]) - (wrap-meta ($form (list ($tag ["lux" "RealS"]) (_meta (#RealS value))))) + (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) (#Meta [_ (#CharS value)]) - (wrap-meta ($form (list ($tag ["lux" "CharS"]) (_meta (#CharS value))))) + (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) (#Meta [_ (#TextS value)]) - (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value))))) + (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) (#Meta [_ (#TagS [module name])]) (let [module' (_lux_case module @@ -851,7 +839,7 @@ _ module)] - (wrap-meta ($form (list ($tag ["lux" "TagS"]) ($tuple (list ($text module') ($text name))))))) + (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) (#Meta [_ (#SymbolS [module name])]) (let [module' (_lux_case module @@ -860,23 +848,23 @@ _ module)] - (wrap-meta ($form (list ($tag ["lux" "SymbolS"]) ($tuple (list ($text module') ($text name))))))) + (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) (#Meta [_ (#TupleS elems)]) - (splice (untemplate subst) ($tag ["lux" "TupleS"]) elems) + (splice (untemplate subst) (tag$ ["lux" "TupleS"]) elems) (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))]) unquoted (#Meta [_ (#FormS elems)]) - (splice (untemplate subst) ($tag ["lux" "FormS"]) elems) + (splice (untemplate subst) (tag$ ["lux" "FormS"]) elems) (#Meta [_ (#RecordS fields)]) - (wrap-meta ($form (list ($tag ["lux" "RecordS"]) + (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) (lambda [kv] (let [[k v] kv] - ($tuple (list (untemplate subst k) (untemplate subst v)))))) + (tuple$ (list (untemplate subst k) (untemplate subst v)))))) fields))))) )) @@ -893,8 +881,11 @@ (#Cons [init apps]) (return (list (foldL (lambda [acc app] (_lux_case app + (#Meta [_ (#TupleS parts)]) + (tuple$ (list:++ parts (list acc))) + (#Meta [_ (#FormS parts)]) - ($form (list:++ parts (list acc))) + (form$ (list:++ parts (list acc))) _ (`' ((~ app) (~ acc))))) @@ -982,7 +973,7 @@ (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) - (return (list (`' (#;TupleT (;list (~@ tokens))))))) + (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) (defmacro (do tokens) (_lux_case tokens @@ -995,7 +986,7 @@ (`' (;let (~ value) (~ body'))) _ - (`' (;bind (_lux_lambda (~ ($symbol ["" ""])) + (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) (~ var) (~ body')) (~ value))))))) @@ -1066,7 +1057,7 @@ _ #Nil)) -(def'' (text:= x y) +(def'' #export (text:= x y) (-> Text Text Bool) (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] x [y])) @@ -1094,13 +1085,13 @@ template) (#Meta [_ (#TupleS elems)]) - ($tuple (map (apply-template env) elems)) + (tuple$ (map (apply-template env) elems)) (#Meta [_ (#FormS elems)]) - ($form (map (apply-template env) elems)) + (form$ (map (apply-template env) elems)) (#Meta [_ (#RecordS members)]) - ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) (lambda [kv] (let [[slot value] kv] [(apply-template env slot) (apply-template env value)]))) @@ -1133,7 +1124,7 @@ return)) _ - (fail "All the do-template bindigns must be symbols.")) + (fail "Wrong syntax for do-template")) _ (fail "Wrong syntax for do-template"))) @@ -1151,6 +1142,19 @@ [real:< _jvm_dlt Real] ) +(do-template [ ] + [(def'' #export ( x y) + (-> Bool) + (if ( x y) + true + ( x y)))] + + [ int:>= int:> int:= Int] + [ int:<= int:< int:= Int] + [real:>= real:> real:= Real] + [real:<= real:< real:= Real] + ) + (do-template [ ] [(def'' #export ( x y) (-> ) @@ -1172,7 +1176,7 @@ (-> Int Int Bool) (int:= 0 (int:% n div))) -(def'' #export (length list) +(def'' (length list) (-> List Int) (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) @@ -1236,13 +1240,14 @@ (#Cons [harg targs]) (let [replacements (map (_lux_: (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) + (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) (list& self-ident idents)) body' (foldL (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))) + (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) (replace-syntax replacements body) (reverse targs))] - (return (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))) + ## (#;Some #;Nil) + (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) #None (fail "'All' arguments must be symbols.")) @@ -1263,7 +1268,19 @@ #Nil #None)) -(def'' #export (get-module-name state) +(def'' (put k v dict) + (All [a] + (-> Text a ($' List (, Text a)) ($' List (, Text a)))) + (_lux_case dict + #Nil + (list [k v]) + + (#Cons [[k' v'] dict']) + (if (text:= k k') + (#Cons [[k' v] dict']) + (#Cons [[k' v'] (put k v dict')])))) + +(def'' (get-module-name state) ($' Lux Text) (_lux_case state {#source source #modules modules @@ -1298,7 +1315,7 @@ _ #None))) -(def'' #export (find-macro ident) +(def'' (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) (do Lux:Monad [current-module get-module-name] @@ -1315,7 +1332,7 @@ (-> ($' List ($' List a)) ($' List a))) (foldL list:++ #Nil xs)) -(def'' #export (normalize ident) +(def'' (normalize ident) (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] @@ -1335,17 +1352,17 @@ (#Meta [_ (#TagS ident)]) (do Lux:Monad [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (;,)]))) + (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) (do Lux:Monad [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) + (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) _ (fail "Wrong syntax for |")))) tokens)] - (;return (list (`' (#;VariantT (;list (~@ pairs)))))))) + (;return (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) (defmacro #export (& tokens) (if (not (multiple? 2 (length tokens))) @@ -1358,18 +1375,18 @@ [(#Meta [_ (#TagS ident)]) value] (do Lux:Monad [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) + (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) _ (fail "Wrong syntax for &")))) (as-pairs tokens))] - (;return (list (`' (#;RecordT (;list (~@ pairs))))))))) + (;return (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) -(def'' #export (->text x) +(def'' (->text x) (-> (^ java.lang.Object) Text) (_jvm_invokevirtual java.lang.Object toString [] x [])) -(def'' #export (interpose sep xs) +(def'' (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) (_lux_case xs @@ -1382,49 +1399,7 @@ (#Cons [x xs']) (list& x sep (interpose sep xs')))) -(def'' #export (syntax:show syntax) - (-> Syntax Text) - (_lux_case syntax - (#Meta [_ (#BoolS value)]) - (->text value) - - (#Meta [_ (#IntS value)]) - (->text value) - - (#Meta [_ (#RealS value)]) - (->text value) - - (#Meta [_ (#CharS value)]) - ($ text:++ "#\"" (->text value) "\"") - - (#Meta [_ (#TextS value)]) - value - - (#Meta [_ (#SymbolS ident)]) - (ident->text ident) - - (#Meta [_ (#TagS ident)]) - (text:++ "#" (ident->text ident)) - - (#Meta [_ (#TupleS members)]) - ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) "]") - - (#Meta [_ (#FormS members)]) - ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) ")") - - (#Meta [_ (#RecordS slots)]) - ($ text:++ "{" - (|> slots - (map (_lux_: (-> (, Syntax Syntax) Text) - (lambda [slot] - (let [[k v] slot] - ($ text:++ (syntax:show k) " " (syntax:show v)))))) - (interpose " ") - (foldL text:++ "")) - "}") - )) - -(def'' #export (macro-expand syntax) +(def'' (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) @@ -1440,19 +1415,19 @@ #None (do Lux:Monad - [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] - (;return (list ($form (list:join parts'))))))) + [parts' (map% Lux:Monad macro-expand (list& (symbol$ macro-name) args))] + (;return (list (form$ (list:join parts'))))))) (#Meta [_ (#FormS (#Cons [harg targs]))]) (do Lux:Monad [harg+ (macro-expand harg) targs+ (map% Lux:Monad macro-expand targs)] - (;return (list ($form (list:++ harg+ (list:join targs+)))))) + (;return (list (form$ (list:++ harg+ (list:join targs+)))))) (#Meta [_ (#TupleS members)]) (do Lux:Monad [members' (map% Lux:Monad macro-expand members)] - (;return (list ($tuple (list:join members'))))) + (;return (list (tuple$ (list:join members'))))) _ (return (list syntax)))) @@ -1461,10 +1436,10 @@ (-> Syntax Syntax) (_lux_case type (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) - ($form (#Cons [($tag tag) (map walk-type parts)])) + (form$ (#Cons [(tag$ tag) (map walk-type parts)])) (#Meta [_ (#TupleS members)]) - ($tuple (map walk-type members)) + (tuple$ (map walk-type members)) (#Meta [_ (#FormS (#Cons [type-fn args]))]) (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) @@ -1474,7 +1449,7 @@ _ type)) -(defmacro #export (type` tokens) +(defmacro #export (type tokens) (_lux_case tokens (#Cons [type #Nil]) (do Lux:Monad @@ -1484,15 +1459,15 @@ (;return (list (walk-type type'))) _ - (fail "type`: The expansion of the type-syntax had to yield a single element."))) + (fail "The expansion of the type-syntax had to yield a single element."))) _ - (fail "Wrong syntax for type`"))) + (fail "Wrong syntax for type"))) (defmacro #export (: tokens) (_lux_case tokens (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (_lux_: (;type` (~ type)) (~ value))))) + (return (list (`' (_lux_: (;type (~ type)) (~ value))))) _ (fail "Wrong syntax for :"))) @@ -1500,7 +1475,7 @@ (defmacro #export (:! tokens) (_lux_case tokens (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (_lux_:! (;type` (~ type)) (~ value))))) + (return (list (`' (_lux_:! (;type (~ type)) (~ value))))) _ (fail "Wrong syntax for :!"))) @@ -1516,10 +1491,10 @@ parts (: (Maybe (, Syntax (List Syntax) Syntax)) (_lux_case tokens' (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) - (#Some [($symbol name) #Nil type]) + (#Some [(symbol$ name) #Nil type]) (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) - (#Some [($symbol name) args type]) + (#Some [(symbol$ name) args type]) _ #None))] @@ -1536,29 +1511,17 @@ _ (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (list& (`' (_lux_def (~ name) (;type` (~ type')))) + (return (list& (`' (_lux_def (~ name) (;type (~ type')))) with-export))) #None (fail "Wrong syntax for deftype")) )) -(deftype #export (IO a) - (-> (,) a)) - -(defmacro #export (io tokens) - (_lux_case tokens - (#Cons [value #Nil]) - (let [blank ($symbol ["" ""])] - (return (list (`' (_lux_lambda (~ blank) (~ blank) (~ value)))))) - - _ - (fail "Wrong syntax for io"))) - (defmacro #export (exec tokens) (_lux_case (reverse tokens) (#Cons [value actions]) - (let [dummy ($symbol ["" ""])] + (let [dummy (symbol$ ["" ""])] (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) value actions)))) @@ -1626,16 +1589,16 @@ [expansions (map% Lux:Monad (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) (lambda expander [branch] - (let [[pattern body] branch] - (_lux_case pattern - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) - (do Lux:Monad - [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args))) - expansions (map% Lux:Monad expander (as-pairs expansion))] - (;return (list:join expansions))) - - _ - (;return (list branch)))))) + (let [[pattern body] branch] + (_lux_case pattern + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) + (do Lux:Monad + [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) + expansions (map% Lux:Monad expander (as-pairs expansion))] + (;return (list:join expansions))) + + _ + (;return (list branch)))))) (as-pairs branches))] (;return (list (`' (_lux_case (~ value) (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) @@ -1680,11 +1643,6 @@ [inc 1] [dec -1]) -(def (int:show int) - (-> Int Text) - (_jvm_invokevirtual java.lang.Object toString [] - int [])) - (defmacro #export (` tokens) (do Lux:Monad [module-name get-module-name] @@ -1695,7 +1653,7 @@ _ (fail "Wrong syntax for `")))) -(def #export (gensym prefix state) +(def (gensym prefix state) (-> Text (Lux Syntax)) (case state {#source source #modules modules @@ -1704,9 +1662,9 @@ (#Right [{#source source #modules modules #envs envs #types types #host host #seed (inc seed) #seen-sources seen-sources #eval? eval?} - ($symbol ["__gensym__" (int:show seed)])]))) + (symbol$ ["__gensym__" (->text seed)])]))) -(def #export (macro-expand-1 token) +(def (macro-expand-1 token) (-> Syntax (Lux Syntax)) (do Lux:Monad [token+ (macro-expand token)] @@ -1719,7 +1677,7 @@ (defmacro #export (sig tokens) (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand-1 tokens) + [tokens' (map% Lux:Monad macro-expand tokens) members (map% Lux:Monad (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] @@ -1731,13 +1689,13 @@ _ (fail "Signatures require typed members!")))) - tokens')] - (;return (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) - (lambda [pair] - (let [[name type] pair] - (`' [(~ (|> name ident->text $text)) - (~ type)])))) - members))))))))) + (list:join tokens'))] + (;return (list (`' (#;RecordT (~ (untemplate-list (map (: (-> (, Ident Syntax) Syntax) + (lambda [pair] + (let [[name type] pair] + (`' [(~ (|> name ident->text text$)) + (~ type)])))) + members))))))))) (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1776,7 +1734,7 @@ (defmacro #export (struct tokens) (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand-1 tokens) + [tokens' (map% Lux:Monad macro-expand tokens) members (map% Lux:Monad (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] @@ -1784,12 +1742,12 @@ (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) (do Lux:Monad [name' (normalize name)] - (;return (: (, Syntax Syntax) [($tag name') value]))) + (;return (: (, Syntax Syntax) [(tag$ name') value]))) _ (fail "Structures require defined members!")))) - tokens')] - (;return (list ($record members))))) + (list:join tokens'))] + (;return (list (record$ members))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1824,48 +1782,12 @@ #Nil)))) #None - (fail "Wrong syntax for defsig")))) - -(defsig #export (Eq a) - (: (-> a a Bool) - =)) - -(do-template [ ] - [(defstruct #export (Eq ) - (def (= x y) - ( x y)))] - - [Int:Eq Int _jvm_leq] - [Real:Eq Real _jvm_deq]) + (fail "Wrong syntax for defstruct")))) (def #export (id x) (All [a] (-> a a)) x) -(defsig #export (Show a) - (: (-> a Text) - show)) - -(do-template [ ] - [(defstruct #export (Show ) - (def (show x) - ))] - - [Bool:Show Bool (->text x)] - [Int:Show Int (->text x)] - [Real:Show Real (->text x)] - [Char:Show Char ($ text:++ "#\"" (->text x) "\"")]) - -(defsig #export (Ord a) - (: (-> a a Bool) - <) - (: (-> a a Bool) - <=) - (: (-> a a Bool) - >) - (: (-> a a Bool) - >=)) - (do-template [ ] [(defmacro #export ( tokens) (case (reverse tokens) @@ -1877,80 +1799,152 @@ _ (fail )))] - [and (if (~ pre) true (~ post)) "and requires >=1 clauses."] - [or (if (~ pre) (~ post) false) "or requires >=1 clauses."]) - -(do-template [ ] - [(defstruct #export (Ord ) - (def (< x y) - ( x y)) - - (def (<= x y) - (or ( x y) - ( x y))) - - (def (> x y) - ( x y)) - - (def (>= x y) - (or ( x y) - ( x y))))] - - [Int:Ord Int _jvm_llt _jvm_lgt _jvm_leq] - [Real:Ord Real _jvm_dlt _jvm_dgt _jvm_deq]) - -(defmacro #export (lux tokens state) + [and (if (~ pre) (~ post) false) "and requires >=1 clauses."] + [or (if (~ pre) true (~ post)) "or requires >=1 clauses."]) + +(deftype Referrals + (| #All + (#Only (List Text)) + (#Except (List Text)) + #Nothing)) + +(deftype Import + (, Text (Maybe Text) Referrals)) + +(def (extract-defs defs) + (-> (List Syntax) (Lux (List Text))) + (map% Lux:Monad + (: (-> Syntax (Lux Text)) + (lambda [def] + (case def + (#Meta [_ (#SymbolS ["" name])]) + (return name) + + _ + (fail "only/except requires symbols.")))) + defs)) + +(def (parse-alias tokens) + (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax)))) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens')) + (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens'])) + + _ + (return (: (, (Maybe Text) (List Syntax)) [#None tokens])))) + +(def (parse-referrals tokens) + (-> (List Syntax) (Lux (, Referrals (List Syntax)))) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens')) + (case referral + (#Meta [_ (#TagS ["" "all"])]) + (return (: (, Referrals (List Syntax)) [#All tokens'])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))])) + (do Lux:Monad + [defs' (extract-defs defs)] + (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "except"])]) defs))])) + (do Lux:Monad + [defs' (extract-defs defs)] + (return (: (, Referrals (List Syntax)) [(#Except defs') tokens']))) + + _ + (fail "Incorrect syntax for referral.")) + + _ + (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) + +(def (decorate-imports super-name tokens) + (-> Text (List Syntax) (Lux (List Syntax))) + (map% Lux:Monad + (: (-> Syntax (Lux Syntax)) + (lambda [token] + (case token + (#Meta [_ (#SymbolS ["" sub-name])]) + (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))])) + (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) + + _ + (fail "Wrong import syntax.")))) + tokens)) + +(def (parse-imports imports) + (-> (List Syntax) (Lux (List Import))) + (do Lux:Monad + [referrals' (map% Lux:Monad + (: (-> Syntax (Lux (List Import))) + (lambda [token] + (case token + (#Meta [_ (#SymbolS ["" m-name])]) + (;return (list [m-name #None #All])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) + (do Lux:Monad + [alias+extra' (parse-alias extra) + #let [[alias extra'] (: (, (Maybe Text) (List Syntax)) + alias+extra')] + referral+extra'' (parse-referrals extra') + #let [[referral extra''] (: (, Referrals (List Syntax)) + referral+extra'')] + extra''' (decorate-imports m-name extra'') + sub-imports (parse-imports extra''')] + (;return (case referral + #Nothing (case alias + #None sub-imports + (#Some _) (list& [m-name alias referral] sub-imports)) + _ (list& [m-name alias referral] sub-imports)))) + + _ + (fail "Wrong syntax for import")))) + imports)] + (;return (list:join referrals')))) + +(def (module-exists? module state) + (-> Text (Lux Bool)) (case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #types types #host host #seed seed #seen-sources seen-sources #eval? eval?} - (case (get "lux" modules) - (#Some lux) + (case (get module modules) + (#Some =module) + (#Right [state true]) + + #None + (#Right [state false])) + )) + +(def (exported-defs module state) + (-> Text (Lux (List Text))) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} + (case (get module modules) + (#Some =module) (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] (if export? - (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) [($ text:++ "Importing: " name "\n")]) - (list name)) + (list name) (list))))) - (let [{#module-aliases _ #defs defs #imports _} lux] + (let [{#module-aliases _ #defs defs #imports _} =module] defs))] - (#Right [state (map (lambda [name] - (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name]))))) - (list:join to-alias))])) + (#Right [state (list:join to-alias)])) #None - (#Left "Uh, oh... The universe is not working properly...")) + (#Left ($ text:++ "Unknown module: " module))) )) -(def #export (print x) - (-> Text (IO (,))) - (lambda [_] - (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) [x]) - []))) - -(def #export (println x) - (-> Text (IO (,))) - (print (text:++ x "\n"))) - -(def #export (some f xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #Nil - #None - - (#Cons [x xs']) - (case (f x) - #None - (some f xs') - - (#Some y) - (#Some y)))) - +(def (last-index-of part text) + (-> Text Text Int) + (_jvm_i2l (_jvm_invokevirtual java.lang.String lastIndexOf [java.lang.String] + text [part]))) (def (index-of part text) (-> Text Text Int) @@ -1967,6 +1961,177 @@ (_jvm_invokevirtual java.lang.String substring [int int] text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) +(def (split-module-contexts module) + (-> Text (List Text)) + (#Cons [module (let [idx (last-index-of "/" module)] + (if (int:< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module))))])) + +(def (split-module module) + (-> Text (List Text)) + (let [idx (index-of "/" module)] + (if (int:< idx 0) + (#Cons [module #Nil]) + (#Cons [(substring2 0 idx module) + (split-module (substring1 (inc idx) module))])))) + +(def (@ idx xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons [x xs']) + (if (int:= idx 0) + (#Some x) + (@ (dec idx) xs') + ))) + +(def (split-with' p ys xs) + (All [a] + (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) + (case xs + #Nil + [ys xs] + + (#Cons [x xs']) + (if (p x) + (split-with' p (list& x ys) xs') + [ys xs]))) + +(def (split-with p xs) + (All [a] + (-> (-> a Bool) (List a) (, (List a) (List a)))) + (let [[ys' xs'] (split-with' p #Nil xs)] + [(reverse ys') xs'])) + +(def (clean-module module) + (-> Text (Lux Text)) + (do Lux:Monad + [module-name get-module-name] + (case (split-module module) + (\ (list& "." parts)) + (return (|> (list& module-name parts) (interpose "/") (foldL text:++ ""))) + + parts + (let [[ups parts'] (split-with (text:= "..") parts) + num-ups (length ups)] + (if (int:= num-ups 0) + (return module) + (case (@ num-ups (split-module-contexts module-name)) + #None + (fail (text:++ "Can't clean module: " module)) + + (#Some top-module) + (return (|> (list& top-module parts') (interpose "/") (foldL text:++ "")))) + ))) + )) + +(def (filter p xs) + (All [a] (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + (list) + + (#;Cons [x xs']) + (if (p x) + (#;Cons [x (filter p xs')]) + (filter p xs')))) + +(def (is-member? cases name) + (-> (List Text) Text Bool) + (let [output (foldL (lambda [prev case] + (or prev + (text:= case name))) + false + cases)] + output)) + +(defmacro #export (import tokens) + (do Lux:Monad + [imports (parse-imports tokens) + imports (map% Lux:Monad + (: (-> Import (Lux Import)) + (lambda [import] + (case import + [m-name m-alias m-referrals] + (do Lux:Monad + [m-name (clean-module m-name)] + (;return (: Import [m-name m-alias m-referrals])))))) + imports) + unknowns' (map% Lux:Monad + (: (-> Import (Lux (List Text))) + (lambda [import] + (case import + [m-name _ _] + (do Lux:Monad + [? (module-exists? m-name)] + (;return (if ? + (list) + (list m-name))))))) + imports) + #let [unknowns (list:join unknowns')]] + (case unknowns + #Nil + (do Lux:Monad + [output' (map% Lux:Monad + (: (-> Import (Lux (List Syntax))) + (lambda [import] + (case import + [m-name m-alias m-referrals] + (do Lux:Monad + [defs (case m-referrals + #All + (exported-defs m-name) + + (#Only +defs) + (do Lux:Monad + [*defs (exported-defs m-name)] + (;return (filter (is-member? +defs) *defs))) + + (#Except -defs) + (do Lux:Monad + [*defs (exported-defs m-name)] + (;return (filter (. not (is-member? -defs)) *defs))) + + #Nothing + (;return (list)))] + (;return ($ list:++ + (list (` (_lux_import (~ (text$ m-name))))) + (case m-alias + #None (list) + (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) + (map (: (-> Text Syntax) + (lambda [def] + (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) + defs))))))) + imports)] + (;return (list:join output'))) + + _ + (;return (: (List Syntax) + (list:++ (map (lambda [m-name] + (` (_lux_import (~ (text$ m-name))))) + unknowns) + (list (` (import (~@ tokens)))))))))) + +(def (some f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #Nil + #None + + (#Cons [x xs']) + (case (f x) + #None + (some f xs') + + (#Some y) + (#Some y)))) + (def (split-slot slot) (-> Text (, Text Text)) (let [idx (index-of ";" slot) @@ -1974,6 +2139,154 @@ name (substring1 (inc idx) slot)] [module name])) +(def (type:show type) + (-> Type Text) + (case type + (#DataT name) + ($ text:++ "(^ " name ")") + + (#TupleT elems) + (case elems + #;Nil + "(,)" + + _ + ($ text:++ "(, " (|> elems (map type:show) (interpose " ") (foldL text:++ "")) ")")) + + (#VariantT cases) + (case cases + #;Nil + "(|)" + + _ + ($ text:++ "(| " + (|> cases + (map (: (-> (, Text Type) Text) + (lambda [kv] + (case kv + [k (#TupleT #;Nil)] + ($ text:++ "#" k) + + [k v] + ($ text:++ "(#" k " " (type:show v) ")"))))) + (interpose " ") + (foldL text:++ "")) + ")")) + + (#RecordT fields) + (case fields + #;Nil + "(&)" + + _ + ($ text:++ "(& " + (|> fields + (map (: (-> (, Text Type) Text) + (: (-> (, Text Type) Text) + (lambda [kv] + (let [[k v] kv] + ($ text:++ "(#" k " " (type:show v) ")")))))) + (interpose " ") + (foldL text:++ "")) + ")")) + + (#LambdaT [input output]) + ($ text:++ "(-> " (type:show input) " " (type:show output) ")") + + (#VarT id) + ($ text:++ "⌈" (->text id) "⌋") + + (#BoundT name) + name + + (#ExT ?id) + ($ text:++ "⟨" (->text ?id) "⟩") + + (#AppT [?lambda ?param]) + ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")") + + (#AllT [?env ?name ?arg ?body]) + ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")") + )) + +(def (beta-reduce env type) + (-> (List (, Text Type)) Type Type) + (case type + (#VariantT ?cases) + (#VariantT (map (: (-> (, Text Type) (, Text Type)) + (lambda [kv] + (let [[k v] kv] + [k (beta-reduce env v)]))) + ?cases)) + + (#RecordT ?fields) + (#RecordT (map (: (-> (, Text Type) (, Text Type)) + (lambda [kv] + (let [[k v] kv] + [k (beta-reduce env v)]))) + ?fields)) + + (#TupleT ?members) + (#TupleT (map (beta-reduce env) ?members)) + + (#AppT [?type-fn ?type-arg]) + (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)]) + + (#AllT [?local-env ?local-name ?local-arg ?local-def]) + (case ?local-env + #None + (#AllT [(#Some env) ?local-name ?local-arg ?local-def]) + + (#Some _) + type) + + (#LambdaT [?input ?output]) + (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)]) + + (#BoundT ?name) + (case (get ?name env) + (#Some bound) + bound + + _ + type) + + _ + type + )) + +(defmacro #export (? tokens) + (case tokens + (\ (list maybe else)) + (do Lux:Monad + [g!value (gensym "")] + (return (list (` (case (~ maybe) + (#;Some (~ g!value)) + (~ g!value) + + _ + (~ else)))))) + + _ + (fail "Wrong syntax for ?"))) + +(def (apply-type type-fn param) + (-> Type Type (Maybe Type)) + (case type-fn + (#AllT [env name arg body]) + (#Some (beta-reduce (|> (? env (list)) + (put name type-fn) + (put arg param)) + body)) + + (#AppT [F A]) + (do Maybe:Monad + [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + _ + #None)) + (def (resolve-struct-type type) (-> Type (Maybe Type)) (case type @@ -1981,7 +2294,7 @@ (#Some type) (#AppT [fun arg]) - (resolve-struct-type fun) + (apply-type fun arg) (#AllT [_ _ _ body]) (resolve-struct-type body) @@ -1989,55 +2302,160 @@ _ #None)) -(defmacro #export (using tokens state) +(def (try-both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #;None (f x2) + (#;Some y) (#;Some y))) + +(def (try-both% x1 x2) + (All [a b] + (-> (Maybe a) (Maybe a) (Maybe a))) + (case x1 + #;None x2 + (#;Some _) x1)) + +(def (find-in-env name state) + (-> Ident Compiler (Maybe Type)) + (let [vname' (ident->text name)] + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} + (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (lambda [env] + (case env + {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} + (try-both% (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= vname' bname) + (#Some type) + #None)))) + locals) + (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= vname' bname) + (#Some type) + #None)))) + closure)) + ## (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + ## (lambda [binding] + ## (let [[bname [_ type]] binding] + ## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + ## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-env #2: " bname "\n")]) + ## (if (text:= vname' bname) + ## (#Some type) + ## #None))))) + ## locals) + ))) + envs)))) + +(def (show-envs envs) + (-> (List (Env Text (, LuxVar Type))) Text) + (|> envs + (map (lambda [env] + (case env + {#name name #inner-closures _ #locals {#counter _ #mappings locals} #closure _} + ($ text:++ name ": " (|> locals + (map (: (All [a] (-> (, Text a) Text)) + (lambda [b] (let [[label _] b] label)))) + (interpose " ") + (foldL text:++ "")))))) + (interpose "\n") + (foldL text:++ ""))) + +(def (find-in-defs name state) + (-> Ident Compiler (Maybe Type)) + (let [[v-prefix v-name] name + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} state] + (case (get v-prefix modules) + #None + #None + + (#Some {#defs defs #module-aliases _ #imports _}) + (case (get v-name defs) + #None + #None + + (#Some [_ def-data]) + (case def-data + #TypeD (#Some Type) + (#ValueD type) (#Some type) + (#MacroD m) (#Some Macro) + (#AliasD name') (find-in-defs name' state)))))) +## (def (find-in-defs name state) +## (-> Ident Compiler (Maybe Type)) +## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] +## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-defs #1: " (ident->text name) "\n")]) +## (let [[v-prefix v-name] name +## {#source source #modules modules +## #envs envs #types types #host host +## #seed seed #seen-sources seen-sources #eval? eval?} state] +## (do Maybe:Monad +## [module (get v-prefix modules) +## #let [{#defs defs #module-aliases _ #imports _} module] +## def (get v-name defs) +## #let [[_ def-data] def]] +## (case def-data +## #TypeD (;return Type) +## (#ValueD type) (;return type) +## (#MacroD m) (;return Macro) +## (#AliasD name') (find-in-defs name' state)))))) + +(def (find-var-type name) + (-> Ident (Lux Type)) + (do Lux:Monad + [name' (normalize name)] + (lambda [state] + (case (find-in-env name state) + (#Some struct-type) + (#Right [state struct-type]) + + _ + (case (find-in-defs name' state) + (#Some struct-type) + (#Right [state struct-type]) + + _ + (let [{#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} state] + (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) + +(defmacro #export (using tokens) (case tokens (\ (list struct body)) (case struct - (#Meta [_ (#SymbolS vname)]) - (let [vname' (ident->text vname)] - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #seen-sources seen-sources #eval? eval?} - (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#name _ #inner-closures _ #locals {#counter _ #mappings mappings} #closure _} - (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#Some type) - #None)))) - mappings)))) - envs)] - (case ?struct-type - #None - (#Left ($ text:++ "Unknown structure: " vname')) - - (#Some struct-type) - (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) - (let [pattern ($record (map (: (-> (, Text Type) (, Syntax Syntax)) - (lambda [slot] - (let [[sname stype] slot - [module name] (split-slot sname)] - [($tag [module name]) ($symbol ["" name])]))) - slots))] - (#Right [state (list (` (_lux_case (~ struct) (~ pattern) (~ body))))])) - - _ - (#Left "Can only \"use\" records.")))))) + (#Meta [_ (#SymbolS name)]) + (do Lux:Monad + [struct-type (find-var-type name)] + (case (resolve-struct-type struct-type) + (#Some (#RecordT slots)) + (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + (lambda [slot] + (let [[sname stype] slot + full-name (split-slot sname)] + [(tag$ full-name) (symbol$ full-name)]))) + slots))] + (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) + _ + (fail "Can only \"use\" records."))) + _ - (let [dummy ($symbol ["" ""])] - (#Right [state (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) - (~ body)))))]))) + (let [dummy (symbol$ ["" ""])] + (return (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) + (~ body)))))))) _ - (#Left "Wrong syntax for defsig"))) + (fail "Wrong syntax for using"))) (def #export (flip f) (All [a b c] @@ -2045,60 +2463,244 @@ (lambda [y x] (f x y))) -## (def #export (curry f) -## (All [a b c] -## (-> (-> (, a b) c) -## (-> a b c))) -## (lambda [x y] -## (f [x y]))) - -## (def #export (uncurry f) -## (All [a b c] -## (-> (-> a b c) -## (-> (, a b) c))) -## (lambda [[x y]] -## (f x y))) - -## (defmacro (loop tokens) -## (_lux_case tokens -## (#Cons [bindings (#Cons [body #Nil])]) -## (let [pairs (as-pairs bindings)] -## (return (list (#FormS (#Cons [(` (lambda (~ (#SymbolS ["" "recur"])) (~ (#TupleS (map first pairs))) -## (~ body))) -## (map second pairs)]))))))) - -## (defmacro (get@ tokens) -## (let [output (_lux_case tokens -## (#Cons [tag (#Cons [record #Nil])]) -## (` (get@' (~ tag) (~ record))) - -## (#Cons [tag #Nil]) -## (` (lambda [record] (get@' (~ tag) record))))] -## (return (list output)))) - -## (defmacro (set@ tokens) -## (let [output (_lux_case tokens -## (#Cons [tag (#Cons [value (#Cons [record #Nil])])]) -## (` (set@' (~ tag) (~ value) (~ record))) - -## (#Cons [tag (#Cons [value #Nil])]) -## (` (lambda [record] (set@' (~ tag) (~ value) record))) - -## (#Cons [tag #Nil]) -## (` (lambda [value record] (set@' (~ tag) value record))))] -## (return (list output)))) - -## (defmacro (update@ tokens) -## (let [output (_lux_case tokens -## (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) -## (` (let [_record_ (~ record)] -## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_))) - -## (#Cons [tag (#Cons [func #Nil])]) -## (` (lambda [record] -## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record)))) - -## (#Cons [tag #Nil]) -## (` (lambda [func record] -## (set@' (~ tag) (func (get@' (~ tag) record)) record))))] -## (return (list output)))) +(def #export (curry f) + (All [a b c] + (-> (-> (, a b) c) + (-> a b c))) + (lambda [x y] + (f [x y]))) + +(def #export (uncurry f) + (All [a b c] + (-> (-> a b c) + (-> (, a b) c))) + (lambda [xy] + (let [[x y] xy] + (f x y)))) + +(defmacro #export (cond tokens) + (if (int:= 0 (int:% (length tokens) 2)) + (fail "cond requires an even number of arguments.") + (case (reverse tokens) + (\ (list& else branches')) + (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [else branch] + (let [[right left] branch] + (` (if (~ left) (~ right) (~ else)))))) + else + (as-pairs branches')))) + + _ + (fail "Wrong syntax for cond")))) + +(defmacro #export (get@ tokens) + (case tokens + (\ (list (#Meta [_ (#TagS slot')]) record)) + (case record + (#Meta [_ (#SymbolS name)]) + (do Lux:Monad + [type (find-var-type name) + g!blank (gensym "") + g!output (gensym "")] + (case (resolve-struct-type type) + (#Some (#RecordT slots)) + (do Lux:Monad + [slot (normalize slot')] + (let [[s-prefix s-name] (: Ident slot) + pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-type] slot + [r-prefix r-name] (split-slot r-slot-name)] + [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) + (text:= s-name r-name)) + g!output + g!blank)]))) + slots))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output))))))) + + _ + (fail "get@ can only use records."))) + + _ + (do Lux:Monad + [_record (gensym "")] + (return (list (` (let [(~ _record) (~ record)] + (get@ (~ (tag$ slot')) (~ _record)))))))) + + _ + (fail "Wrong syntax for get@"))) + +(defmacro #export (open tokens) + (case tokens + (\ (list (#Meta [_ (#SymbolS struct-name)]))) + (do Lux:Monad + [struct-type (find-var-type struct-name)] + (case (resolve-struct-type struct-type) + (#Some (#RecordT slots)) + (return (map (: (-> (, Text Type) Syntax) + (lambda [slot] + (let [[sname stype] slot + [module name] (split-slot sname)] + (` (_lux_def (~ (symbol$ ["" name])) + (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name)))))))) + slots)) + + _ + (fail "Can only \"open\" records."))) + + _ + (fail "Wrong syntax for open"))) + +(def (foldL% M f x ys) + (All [m a b] + (-> (Monad m) (-> a b (m a)) a (List b) + (m a))) + (case ys + (#Cons [y ys']) + (do M + [x' (f x y)] + (foldL% M f x' ys')) + + #Nil + ((get@ #return M) x))) + +(defmacro #export (:: tokens) + (case tokens + (\ (list& start parts)) + (do Lux:Monad + [output (foldL% Lux:Monad + (: (-> Syntax Syntax (Lux Syntax)) + (lambda [so-far part] + (case part + (#Meta [_ (#SymbolS slot)]) + (return (` (get@ (~ (tag$ slot)) (~ so-far)))) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))])) + (return (` ((get@ (~ (tag$ slot)) (~ so-far)) + (~@ args)))) + + _ + (fail "Wrong syntax for ::")))) + start parts)] + (return (list output))) + + _ + (fail "Wrong syntax for ::"))) + +(defmacro #export (set@ tokens) + (case tokens + (\ (list (#Meta [_ (#TagS slot')]) value record)) + (case record + (#Meta [_ (#SymbolS name)]) + (do Lux:Monad + [type (find-var-type name)] + (case (resolve-struct-type type) + (#Some (#RecordT slots)) + (do Lux:Monad + [pattern' (map% Lux:Monad + (: (-> (, Text Type) (Lux (, Text Syntax))) + (lambda [slot] + (let [[r-slot-name r-type] slot] + (do Lux:Monad + [g!slot (gensym "")] + (return [r-slot-name g!slot]))))) + slots) + slot (normalize slot')] + (let [[s-prefix s-name] (: Ident slot) + pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-var] slot] + [(tag$ (split-slot r-slot-name)) r-var]))) + pattern')) + output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-var] slot + [r-prefix r-name] (split-slot r-slot-name)] + [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) + (text:= s-name r-name)) + value + r-var)]))) + pattern'))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + + _ + (fail "set@ can only use records."))) + + _ + (do Lux:Monad + [_record (gensym "")] + (return (list (` (let [(~ _record) (~ record)] + (set@ (~ (tag$ slot')) (~ value) (~ _record)))))))) + + _ + (fail "Wrong syntax for set@"))) + +(defmacro #export (update@ tokens) + (case tokens + (\ (list (#Meta [_ (#TagS slot')]) fun record)) + (case record + (#Meta [_ (#SymbolS name)]) + (do Lux:Monad + [type (find-var-type name)] + (case (resolve-struct-type type) + (#Some (#RecordT slots)) + (do Lux:Monad + [pattern' (map% Lux:Monad + (: (-> (, Text Type) (Lux (, Text Syntax))) + (lambda [slot] + (let [[r-slot-name r-type] slot] + (do Lux:Monad + [g!slot (gensym "")] + (return [r-slot-name g!slot]))))) + slots) + slot (normalize slot')] + (let [[s-prefix s-name] (: Ident slot) + pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-var] slot] + [(tag$ (split-slot r-slot-name)) r-var]))) + pattern')) + output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-var] slot + [r-prefix r-name] (split-slot r-slot-name)] + [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) + (text:= s-name r-name)) + (` ((~ fun) (~ r-var))) + r-var)]))) + pattern'))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + + _ + (fail "update@ can only use records."))) + + _ + (do Lux:Monad + [_record (gensym "")] + (return (list (` (let [(~ _record) (~ record)] + (update@ (~ (tag$ slot')) (~ fun) (~ _record)))))))) + + _ + (fail "Wrong syntax for update@"))) + +## (defmacro #export (loop tokens) +## (case tokens +## (\ (list bindings body)) +## (let [pairs (as-pairs bindings) +## vars (map first pairs) +## inits (map second pairs)] +## (if (every? symbol? inits) +## (do Lux:Monad +## [inits' (map% Maybe:Monad get-ident inits) +## init-types (map% Maybe:Monad find-var-type inits')] +## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] +## (~ body)) +## (~@ inits)))))) +## (do Lux:Monad +## [aliases (map% Maybe:Monad (lambda [_] (gensym "")) inits)] +## (return (list (` (let [(~@ (interleave aliases inits))] +## (loop [(~@ (interleave vars aliases))] +## (~ body))))))))) + +## _ +## (fail "Wrong syntax for loop"))) diff --git a/input/lux/codata/stream.lux b/input/lux/codata/stream.lux new file mode 100644 index 000000000..1bfd19292 --- /dev/null +++ b/input/lux/codata/stream.lux @@ -0,0 +1,63 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (control (lazy #as L #refer #all)))) + +## Types +(deftype #export (Stream a) + (Lazy (, a (Stream a)))) + +## Functions +(def #export (iterate f x) + (All [a] + (-> (-> a a) a (Stream a))) + (... [x (iterate f (f x))])) + +## (def #export (take n xs) +## (All [a] +## (-> Int (Stream a) (List a))) +## (if (int:> n 0) +## (let [[x xs'] (! xs)] +## (list& x (take (dec n) xs'))) +## (list))) + +## (def #export (drop n xs) +## (All [a] +## (-> Int (Stream a) (Stream a))) +## (if (int:> n 0) +## (drop (dec n) (get@ 1 (! xs))) +## xs)) + +## Pattern-matching +## (defmacro #export (\stream tokens) +## (case tokens +## (\ (list& body patterns')) +## (do Lux:Monad +## [patterns (map% Lux:Monad M;macro-expand-1 patterns') +## g!s (M;gensym "s") +## #let [patterns+ (do List:Monad +## [pattern (reverse patterns)] +## (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))]] +## (wrap (list g!s +## (` (;let [(~@ patterns+)] +## (~ body)))))) + +## _ +## "Wrong syntax for \stream")) + +## (defsyntax #export (\stream body [patterns' (+$ id$)]) +## (do Lux:Monad +## [patterns (map% Lux:Monad M;macro-expand-1 patterns') +## g!s (M;gensym "s") +## #let [patterns+ (do List:Monad +## [pattern (reverse patterns)] +## (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))]] +## (wrap (list g!s +## (` (;let [(~@ patterns+)] +## (~ body))))))) diff --git a/input/lux/control/comonad.lux b/input/lux/control/comonad.lux new file mode 100644 index 000000000..1830ff44f --- /dev/null +++ b/input/lux/control/comonad.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (../functor #as F) + lux/data/list + lux/meta/macro) + +## Signatures +(defsig #export (CoMonad w) + (: (F;Functor w) + _functor) + (: (All [a] + (-> (w a) a)) + unwrap) + (: (All [a] + (-> (w a) (w (w a)))) + split)) + +## Functions +(def #export (extend w f ma) + (All [w a b] + (-> (CoMonad w) (-> (w a) b) (w a) (w b))) + (using w + (using ;;_functor + (F;map f (;;split ma))))) + +## Syntax +(defmacro #export (be tokens state) + (case tokens + (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (case var + (#;Meta [_ (#;TagS ["" "let"])]) + (` (;let (~ value) (~ body'))) + + _ + (` (extend (;lambda [(~ var)] (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (list (` (;case (~ monad) + {#;return ;return #;bind ;bind} + (~ body'))))])) + + _ + (#;Left "Wrong syntax for be"))) diff --git a/input/lux/control/functor.lux b/input/lux/control/functor.lux new file mode 100644 index 000000000..3362dd21a --- /dev/null +++ b/input/lux/control/functor.lux @@ -0,0 +1,35 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data state)) + +## Signatures +(defsig #export (Functor f) + (: (All [a b] + (-> (-> a b) (f a) (f b))) + map)) + +## Structures +(defstruct #export Maybe:Functor (Functor Maybe) + (def (map f ma) + (case ma + #;None #;None + (#;Some a) (#;Some (f a))))) + +(defstruct #export List:Functor (Functor List) + (def (map f ma) + (case ma + #;Nil #;Nil + (#;Cons [a ma']) (#;Cons [(f a) (map f ma')])))) + +(defstruct #export State:Functor (Functor State) + (def (map f ma) + (lambda [state] + (let [[state' a] (ma state)] + [state' (f a)])))) diff --git a/input/lux/control/lazy.lux b/input/lux/control/lazy.lux new file mode 100644 index 000000000..83f094592 --- /dev/null +++ b/input/lux/control/lazy.lux @@ -0,0 +1,47 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/meta macro) + (.. (functor #as F #refer #all) + (monad #as M #refer #all)) + (lux/data list)) + +## Types +(deftype #export (Lazy a) + (All [b] + (-> (-> a b) b))) + +## Syntax +(defmacro #export (... tokens state) + (case tokens + (\ (list value)) + (let [blank (symbol$ ["" ""])] + (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) + + _ + (#;Left "Wrong syntax for ..."))) + +## Functions +(def #export (! thunk) + (All [a] + (-> (Lazy a) a)) + (thunk id)) + +## Structs +(defstruct #export Lazy:Functor (Functor Lazy) + (def (F;map f ma) + (... (f (! ma))))) + +(defstruct #export Lazy:Monad (Monad Lazy) + (def M;_functor Lazy:Functor) + + (def (M;wrap a) + (... a)) + + (def M;join !)) diff --git a/input/lux/control/monad.lux b/input/lux/control/monad.lux new file mode 100644 index 000000000..2ca541574 --- /dev/null +++ b/input/lux/control/monad.lux @@ -0,0 +1,107 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data list + state) + (.. (functor #as F) + (monoid #as M)) + lux/meta/macro) + +## Signatures +(defsig #export (Monad m) + (: (F;Functor m) + _functor) + (: (All [a] + (-> a (m a))) + wrap) + (: (All [a] + (-> (m (m a)) (m a))) + join)) + +## Syntax +(defmacro #export (do tokens state) + (case tokens + (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (case var + (#;Meta [_ (#;TagS ["" "let"])]) + (` (;let (~ value) (~ body'))) + + _ + (` (;case ;;_functor + {#F;map F;map} + (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join)))) + ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) + )))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (list (` (;case (~ monad) + {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} + (~ body'))))])) + + _ + (#;Left "Wrong syntax for do"))) + +## Structures +(defstruct #export Maybe:Monad (Monad Maybe) + (def _functor F;Maybe:Functor) + + (def (wrap x) + (#;Some x)) + + (def (join mma) + (case mma + #;None #;None + (#;Some xs) xs))) + +(defstruct #export List:Monad (Monad List) + (def _functor F;List:Functor) + + (def (wrap x) + (#;Cons [x #;Nil])) + + (def (join xss) + (using M;List:Monoid + (foldL M;++ M;unit xss)))) + +(defstruct #export State:Monad (All [s] + (Monad (State s))) + (def _functor F;State:Functor) + + (def (wrap x) + (lambda [state] + [state x])) + + (def (join mma) + (lambda [state] + (let [[state' ma] (mma state)] + (ma state'))))) + +## Functions +(def #export (bind m f ma) + (All [m a b] + (-> (Monad m) (-> a (m b)) (m a) (m b))) + (using m + (;;join (:: ;;_functor (F;map f ma))))) + +(def #export (map% m f xs) + (All [m a b] + (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (case xs + #;Nil + (:: m (;;wrap #;Nil)) + + (#;Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;;wrap (#;Cons [y ys]))) + )) diff --git a/input/lux/control/monoid.lux b/input/lux/control/monoid.lux new file mode 100644 index 000000000..cfb282c52 --- /dev/null +++ b/input/lux/control/monoid.lux @@ -0,0 +1,57 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data ord + (bounded #as B))) + +## Signatures +(defsig #export (Monoid a) + (: a + unit) + (: (-> a a a) + ++)) + +## Constructors +(def #export (monoid$ unit ++) + (All [a] + (-> a (-> a a a) (Monoid a))) + (struct + (def unit unit) + (def ++ ++))) + +## Structures +(defstruct #export Maybe:Monoid (Monoid Maybe) + (def unit #;None) + (def (++ xs ys) + (case xs + #;None ys + (#;Some x) (#;Some x)))) + +(defstruct #export List:Monoid (All [a] + (Monoid (List a))) + (def unit #;Nil) + (def (++ xs ys) + (case xs + #;Nil ys + (#;Cons [x xs']) (#;Cons [x (++ xs' ys)])))) + +(do-template [ <++>] + [(defstruct #export (Monoid ) + (def unit ) + (def ++ <++>))] + + [ IntAdd:Monoid Int 0 int:+] + [ IntMul:Monoid Int 1 int:*] + [RealAdd:Monoid Real 0.0 real:+] + [RealMul:Monoid Real 1.0 real:*] + [ IntMax:Monoid Int (:: B;Int:Bounded B;bottom) (max Int:Ord)] + [ IntMin:Monoid Int (:: B;Int:Bounded B;top) (min Int:Ord)] + [RealMax:Monoid Real (:: B;Real:Bounded B;bottom) (max Real:Ord)] + [RealMin:Monoid Real (:: B;Real:Bounded B;top) (min Real:Ord)] + ) diff --git a/input/lux/data/bounded.lux b/input/lux/data/bounded.lux new file mode 100644 index 000000000..14f4d2e86 --- /dev/null +++ b/input/lux/data/bounded.lux @@ -0,0 +1,26 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Bounded a) + (: a + top) + + (: a + bottom)) + +## Structure +(do-template [ ] + [(defstruct #export (Bounded ) + (def top ) + (def bottom ))] + + [Int:Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] + [Real:Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) diff --git a/input/lux/data/dict.lux b/input/lux/data/dict.lux new file mode 100644 index 000000000..8bd6635fd --- /dev/null +++ b/input/lux/data/dict.lux @@ -0,0 +1,83 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data (eq #as E))) + +## Signatures +(defsig #export (Dict d) + (: (All [k v] + (-> k (d k v) (Maybe v))) + get) + (: (All [k v] + (-> k v (d k v) (d k v))) + put) + (: (All [k v] + (-> k (d k v) (d k v))) + remove)) + +## Types +(deftype #export (PList k v) + (| (#PList (, (E;Eq k) (List (, k v)))))) + +## Constructors +(def #export (plist eq) + (All [k v] + (-> (E;Eq k) (PList k v))) + (#PList [eq #;Nil])) + +## Utils +(def (pl-get eq k kvs) + (All [k v] + (-> (E;Eq k) k (List (, k v)) (Maybe v))) + (case kvs + #;Nil + #;None + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + (#;Some v') + (pl-get eq k kvs')))) + +(def (pl-put eq k v kvs) + (All [k v] + (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) + (case kvs + #;Nil + (#;Cons [[k v] kvs]) + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + (#;Cons [[k v] kvs']) + (#;Cons [[k' v'] (pl-put eq k v kvs')])))) + +(def (pl-remove eq k kvs) + (All [k v] + (-> (E;Eq k) k (List (, k v)) (List (, k v)))) + (case kvs + #;Nil + kvs + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + kvs' + (#;Cons [[k' v'] (pl-remove eq k kvs')])))) + +## Structs +(defstruct #export PList:Dict (Dict PList) + (def (get k plist) + (let [(#PList [eq kvs]) plist] + (pl-get eq k kvs))) + + (def (put k v plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-put eq k v kvs)]))) + + (def (remove k plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-remove eq k kvs)])))) diff --git a/input/lux/data/eq.lux b/input/lux/data/eq.lux new file mode 100644 index 000000000..948f8e2ab --- /dev/null +++ b/input/lux/data/eq.lux @@ -0,0 +1,35 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Eq a) + (: (-> a a Bool) + =)) + +## Structures +(defstruct #export Bool:Eq (Eq Bool) + (def (= x y) + (case (: (, Bool Bool) [x y]) + (\or [true true] [false false]) + true + + _ + false))) + +(defstruct #export Int:Eq (Eq Int) + (def = int:=)) + +(defstruct #export Real:Eq (Eq Real) + (def = real:=)) + +(defstruct #export Text:Eq (Eq Text) + (def (= x y) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y]))) diff --git a/input/lux/data/io.lux b/input/lux/data/io.lux new file mode 100644 index 000000000..ab74daefd --- /dev/null +++ b/input/lux/data/io.lux @@ -0,0 +1,51 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/meta macro) + (lux/control (functor #as F) + (monad #as M)) + lux/data/list) + +## Types +(deftype #export (IO a) + (-> (,) a)) + +## Syntax +(defmacro #export (io tokens state) + (case tokens + (\ (list value)) + (let [blank (symbol$ ["" ""])] + (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))])) + + _ + (#;Left "Wrong syntax for io"))) + +## Structures +(defstruct #export IO:Functor (F;Functor IO) + (def (F;map f ma) + (io (f (ma []))))) + +(defstruct #export IO:Monad (M;Monad IO) + (def M;_functor IO:Functor) + + (def (M;wrap x) + (io x)) + + (def (M;join mma) + (mma []))) + +## Functions +(def #export (print x) + (-> Text (IO (,))) + (io (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [x]))) + +(def #export (println x) + (-> Text (IO (,))) + (print (text:++ x "\n"))) diff --git a/input/lux/data/list.lux b/input/lux/data/list.lux new file mode 100644 index 000000000..edbdb6160 --- /dev/null +++ b/input/lux/data/list.lux @@ -0,0 +1,218 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import (lux #refer (#except reverse as-pairs)) + lux/meta/macro) + +## Types +## (deftype (List a) +## (| #Nil +## (#Cons (, a (List a))))) + +## Functions +(def #export (foldL f init xs) + (All [a b] + (-> (-> a b a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + +(def #export (foldR f init xs) + (All [a b] + (-> (-> b a a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (f x (foldR f init xs')))) + +(def #export (reverse xs) + (All [a] + (-> (List a) (List a))) + (foldL (lambda [tail head] (#;Cons [head tail])) + #;Nil + xs)) + +(def #export (filter p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + (#;Cons [x (filter p xs')]) + (filter p xs')))) + +(def #export (as-pairs xs) + (All [a] (-> (List a) (List (, a a)))) + (case xs + (\ (#;Cons [x1 (#;Cons [x2 xs'])])) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +(do-template [ ] + [(def #export ( n xs) + (All [a] + (-> Int (List a) (List a))) + (if (int:> n 0) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + ) + ))] + + [take (#;Cons [x (take (dec n) xs')]) #;Nil] + [drop (drop (dec n) xs') xs] + ) + +(do-template [ ] + [(def #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + + )))] + + [take-while (#;Cons [x (take-while p xs')]) #;Nil] + [drop-while (drop-while p xs') xs] + ) + +(def #export (split-at n xs) + (All [a] + (-> Int (List a) (, (List a) (List a)))) + (if (int:> n 0) + (case xs + #;Nil + [#;Nil #;Nil] + + (#;Cons [x xs']) + (let [[tail rest] (split-at (dec n) xs')] + [(#;Cons [x tail]) rest])) + [#;Nil xs])) + +(def (split-with' p ys xs) + (All [a] + (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) + (case xs + #;Nil + [ys xs] + + (#;Cons [x xs']) + (if (p x) + (split-with' p (#;Cons [x ys]) xs') + [ys xs]))) + +(def #export (split-with p xs) + (All [a] + (-> (-> a Bool) (List a) (, (List a) (List a)))) + (let [[ys' xs'] (split-with' p #;Nil xs)] + [(reverse ys') xs'])) + +(def #export (repeat n x) + (All [a] + (-> Int a (List a))) + (if (int:> n 0) + (#;Cons [x (repeat (dec n) x)]) + #;Nil)) + +(def #export (iterate f x) + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#;Some x') + (#;Cons [x (iterate f x')]) + + #;None + (#;Cons [x #;Nil]))) + +(def #export (some f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #;Nil + #;None + + (#;Cons [x xs']) + (case (f x) + #;None + (some f xs') + + (#;Some y) + (#;Some y)))) + +(def #export (interpose sep xs) + (All [a] + (-> a (List a) (List a))) + (case xs + #;Nil + xs + + (#;Cons [x #;Nil]) + xs + + (#;Cons [x xs']) + (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) + +(def #export (size list) + (-> List Int) + (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) + +(do-template [ ] + [(def #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (foldL (lambda [_1 _2] ( _1 (p _2))) xs))] + + [every? true and] + [any? false or]) + +(def #export (@ i xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons [x xs']) + (if (int:= 0 i) + (#;Some x) + (@ (dec i) xs')))) + +## Syntax +(defmacro #export (list xs state) + (#;Right [state (#;Cons [(foldL (lambda [tail head] + (` (#;Cons [(~ head) (~ tail)]))) + (` #;Nil) + (reverse xs)) + #;Nil])])) + +(defmacro #export (list& xs state) + (case (reverse xs) + (#;Cons [last init]) + (#;Right [state (list (foldL (lambda [tail head] + (` (#;Cons [(~ head) (~ tail)]))) + last + init))]) + + _ + (#;Left "Wrong syntax for list&"))) diff --git a/input/lux/data/number.lux b/input/lux/data/number.lux new file mode 100644 index 000000000..7941daa4e --- /dev/null +++ b/input/lux/data/number.lux @@ -0,0 +1,64 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Number n) + (: (-> n n n) + +) + + (: (-> n n n) + -) + + (: (-> n n n) + *) + + (: (-> n n n) + /) + + (: (-> n n n) + %) + + (: (-> Int n) + from-int) + + (: (-> n n) + negate) + + (: (-> n n) + sign) + + (: (-> n n) + abs)) + +## Structures +(do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] + [(defstruct #export (Number ) + (def + <+>) + (def - <->) + (def * <*>) + (def / ) + (def % <%>) + (def (from-int x) + ( x)) + (def (negate x) + (<*> <-1> x)) + (def (abs x) + (if (<<> x <0>) + (<*> <-1> x) + x)) + (def (sign x) + (cond (<=> x <0>) <0> + (<<> x <0>) <-1> + ## else + <1>)) + )] + + [Int:Number Int int:+ int:- int:* int:/ int:% int:= int:< id 0 1 -1] + [Real:Number Real real:+ real:- real:* real:/ real:% real:= real:< _jvm_l2d 0.0 1.0 -1.0]) diff --git a/input/lux/data/ord.lux b/input/lux/data/ord.lux new file mode 100644 index 000000000..573106830 --- /dev/null +++ b/input/lux/data/ord.lux @@ -0,0 +1,56 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (../eq #as E)) + +## Signatures +(defsig #export (Ord a) + (: (E;Eq a) + _eq) + (: (-> a a Bool) + <) + (: (-> a a Bool) + <=) + (: (-> a a Bool) + >) + (: (-> a a Bool) + >=)) + +## Constructors +(def #export (ord$ eq < >) + (All [a] + (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) + (struct + (def _eq eq) + (def < <) + (def (<= x y) + (or (< x y) + (:: eq (E;= x y)))) + (def > >) + (def (>= x y) + (or (> x y) + (:: eq (E;= x y)))))) + +## Functions +(do-template [ ] + [(def #export ( ord x y) + (All [a] + (-> (Ord a) a a a)) + (using ord + (if ( x y) x y)))] + + [max ;;>] + [min ;;<]) + +## Structures +(def #export Int:Ord (Ord Int) + (ord$ E;Int:Eq int:< int:>)) + +(def #export Real:Ord (Ord Real) + (ord$ E;Real:Eq real:< real:>)) diff --git a/input/lux/data/show.lux b/input/lux/data/show.lux new file mode 100644 index 000000000..3748d481a --- /dev/null +++ b/input/lux/data/show.lux @@ -0,0 +1,27 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Show a) + (: (-> a Text) + show)) + +## Structures +(do-template [ ] + [(defstruct #export (Show ) + (def (show x) + ))] + + [Bool:Show Bool (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Int:Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Real:Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Char:Show Char (let [char (_jvm_invokevirtual java.lang.Object toString [] x [])] + ($ text:++ "#\"" char "\""))] + [Text:Show Text x]) diff --git a/input/lux/data/state.lux b/input/lux/data/state.lux new file mode 100644 index 000000000..386c7be1d --- /dev/null +++ b/input/lux/data/state.lux @@ -0,0 +1,13 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Types +(deftype #export (State s a) + (-> s (, s a))) diff --git a/input/lux/data/text.lux b/input/lux/data/text.lux new file mode 100644 index 000000000..1a8587f46 --- /dev/null +++ b/input/lux/data/text.lux @@ -0,0 +1,139 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data (eq #as E) + (ord #as O))) + +## [Functions] +(def #export (size x) + (-> Text Int) + (_jvm_i2l (_jvm_invokevirtual java.lang.String length [] + x []))) + +(def #export (@ idx x) + (-> Int Text (Maybe Char)) + (if (and (int:< idx (size x)) + (int:>= idx 0)) + (#;Some (_jvm_invokevirtual java.lang.String charAt [int] + x [(_jvm_l2i idx)])) + #;None)) + +(def #export (++ x y) + (-> Text Text Text) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y])) + +(def #export (contains? x y) + (-> Text Text Bool) + (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence] + x [y])) + +(do-template [ ] + [(def #export ( x) + (-> Text Text) + (_jvm_invokevirtual java.lang.String [] + x []))] + [lower-case toLowerCase] + [upper-case toUpperCase] + [trim trim] + ) + +(def #export (sub' from to x) + (-> Int Int Text (Maybe Text)) + (if (and (int:< from to) + (int:>= from 0) + (int:<= to (size x))) + (_jvm_invokevirtual java.lang.String substring [int int] + x [(_jvm_l2i from) (_jvm_l2i to)]) + #;None)) + +(def #export (sub from x) + (-> Int Text (Maybe Text)) + (sub' from (size x) x)) + +(def #export (split at x) + (-> Int Text (Maybe (, Text Text))) + (if (and (int:< at (size x)) + (int:>= at 0)) + (let [pre (_jvm_invokevirtual java.lang.String substring [int int] + x [(_jvm_l2i 0) (_jvm_l2i at)]) + post (_jvm_invokevirtual java.lang.String substring [int] + x [(_jvm_l2i at)])] + (#;Some [pre post])) + #;None)) + +(def #export (replace pattern value template) + (-> Text Text Text Text) + (_jvm_invokevirtual java.lang.String replace [java.lang.CharSequence java.lang.CharSequence] + template [pattern value])) + +(do-template [ ] + [(def #export ( pattern from x) + (-> Text Int Text (Maybe Int)) + (if (and (int:< from (size x)) + (int:>= from 0)) + (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String int] + x [pattern (_jvm_l2i from)])) + -1 #;None + idx (#;Some idx)) + #;None)) + + (def #export ( pattern x) + (-> Text Text (Maybe Int)) + (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String] + x [pattern])) + -1 #;None + idx (#;Some idx)))] + + [index-of index-of' indexOf] + [last-index-of last-index-of' lastIndexOf] + ) + +(def #export (starts-with? prefix x) + (-> Text Text Bool) + (case (index-of prefix x) + (#;Some 0) + true + + _ + false)) + +(def #export (ends-with? postfix x) + (-> Text Text Bool) + (case (last-index-of postfix x) + (#;Some n) + (int:= (int:+ n (size postfix)) + (size x)) + + _ + false)) + +(defstruct #export Text:Eq (E;Eq Text) + (def (E;= x y) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y]))) + +(defstruct #export Text:Ord (O;Ord Text) + (def O;_eq Text:Eq) + (def (O;< x y) + (int:< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;<= x y) + (int:<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;> x y) + (int:> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;>= x y) + (int:>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0))) diff --git a/input/lux/meta/lux.lux b/input/lux/meta/lux.lux new file mode 100644 index 000000000..bd4fab8b6 --- /dev/null +++ b/input/lux/meta/lux.lux @@ -0,0 +1,185 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. macro) + (lux/control (monoid #as m #refer (#only List:Monoid)) + (functor #as F) + (monad #as M #refer (#only do))) + (lux/data list + (show #as S))) + +## Types +## (deftype (Lux a) +## (-> Compiler (Either Text (, Compiler a)))) + +## Structures +(defstruct #export Lux:Functor (F;Functor Lux) + (def (F;map f fa) + (lambda [state] + (case (fa state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' a]) + (#;Right [state' (f a)]))))) + +(defstruct #export Lux:Monad (M;Monad Lux) + (def M;_functor Lux:Functor) + (def (M;wrap x) + (lambda [state] + (#;Right [state x]))) + (def (M;join mma) + (lambda [state] + (case (mma state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' ma]) + (ma state'))))) + +## Functions +(def #export (get-module-name state) + (Lux Text) + (case (reverse (get@ #;envs state)) + #;Nil + (#;Left "Can't get the module name without a module!") + + (#;Cons [env _]) + (#;Right [state (get@ #;name env)]))) + +(def (get k plist) + (All [a] + (-> Text (List (, Text a)) (Maybe a))) + (case plist + #;Nil + #;None + + (#;Cons [[k' v] plist']) + (if (text:= k k') + (#;Some v) + (get k plist')))) + +(def (find-macro' modules current-module module name) + (-> (List (, Text (Module Compiler))) Text Text Text + (Maybe Macro)) + (do M;Maybe:Monad + [$module (get module modules) + gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))] + (case (: (, Bool (DefData' Macro)) gdef) + [exported? (#;MacroD macro')] + (if (or exported? (text:= module current-module)) + (#;Some macro') + #;None) + + [_ (#;AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #;None))) + +(def #export (find-macro ident) + (-> Ident (Lux (Maybe Macro))) + (do Lux:Monad + [current-module get-module-name] + (let [[module name] ident] + (: (Lux (Maybe Macro)) + (lambda [state] + (#;Right [state (find-macro' (get@ #;modules state) current-module module name)])))))) + +(def #export (normalize ident) + (-> Ident (Lux Ident)) + (case ident + ["" name] + (do Lux:Monad + [module-name get-module-name] + (M;wrap (: Ident [module-name name]))) + + _ + (:: Lux:Monad (M;wrap ident)))) + +(def #export (macro-expand syntax) + (-> Syntax (Lux (List Syntax))) + (case syntax + (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) + (do Lux:Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Lux:Monad + [expansion (macro args) + expansion' (M;map% Lux:Monad macro-expand expansion)] + (M;wrap (:: M;List:Monad (M;join expansion')))) + + #;None + (do Lux:Monad + [parts' (M;map% Lux:Monad macro-expand (list& (symbol$ macro-name) args))] + (M;wrap (list (form$ (:: M;List:Monad (M;join parts')))))))) + + (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) + (do Lux:Monad + [harg+ (macro-expand harg) + targs+ (M;map% Lux:Monad macro-expand targs)] + (M;wrap (list (form$ (list:++ harg+ (:: M;List:Monad (M;join (: (List (List Syntax)) targs+)))))))) + + (#;Meta [_ (#;TupleS members)]) + (do Lux:Monad + [members' (M;map% Lux:Monad macro-expand members)] + (M;wrap (list (tuple$ (:: M;List:Monad (M;join members')))))) + + _ + (:: Lux:Monad (M;wrap (list syntax))))) + +(def #export (gensym prefix state) + (-> Text (Lux Syntax)) + (#;Right [(update@ #;seed inc state) + (symbol$ ["__gensym__" (:: S;Int:Show (S;show (get@ #;seed state)))])])) + +(def #export (fail msg) + (All [a] + (-> Text (Lux a))) + (lambda [_] + (#;Left msg))) + +(def #export (macro-expand-1 token) + (-> Syntax (Lux Syntax)) + (do Lux:Monad + [token+ (macro-expand token)] + (case token+ + (\ (list token')) + (M;wrap token') + + _ + (fail "Macro expanded to more than 1 element.")))) + +(def #export (module-exists? module state) + (-> Text (Lux Bool)) + (#;Right [state (case (get module (get@ #;modules state)) + (#;Some _) + true + + #;None + false)])) + +(def #export (exported-defs module state) + (-> Text (Lux (List Text))) + (case (get module (get@ #;modules state)) + (#;Some =module) + (using M;List:Monad + (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) + (List Text)) + (lambda [gdef] + (let [[name [export? _]] gdef] + (if export? + (list name) + (list))))) + (get@ #;defs =module))))])) + + #;None + (#;Left ($ text:++ "Unknown module: " module)))) diff --git a/input/lux/meta/macro.lux b/input/lux/meta/macro.lux new file mode 100644 index 000000000..22aeaf874 --- /dev/null +++ b/input/lux/meta/macro.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Utils] +(def (_meta x) + (-> (Syntax' (Meta Cursor)) Syntax) + (#;Meta [["" -1 -1] x])) + +## [Syntax] +(def #export (defmacro tokens state) + Macro + (case tokens + (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) + (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) + (~ (_meta (#;SymbolS ["lux" "Macro"]))) + (~ body))) + (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + #;Nil])])]) + + (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) + (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args)) + (~ (_meta (#;SymbolS ["lux" "Macro"]))) + (~ body))) + (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + #;Nil])])]) + + _ + (#;Left "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) + +## [Functions] +(do-template [ ] + [(def #export ( x) + (-> Syntax) + (#;Meta [["" -1 -1] ( x)]))] + + [bool$ Bool #;BoolS] + [int$ Int #;IntS] + [real$ Real #;RealS] + [char$ Char #;CharS] + [text$ Text #;TextS] + [symbol$ Ident #;SymbolS] + [tag$ Ident #;TagS] + [form$ (List Syntax) #;FormS] + [tuple$ (List Syntax) #;TupleS] + [record$ (List (, Syntax Syntax)) #;RecordS] + ) diff --git a/input/lux/meta/syntax.lux b/input/lux/meta/syntax.lux new file mode 100644 index 000000000..cf08ff0eb --- /dev/null +++ b/input/lux/meta/syntax.lux @@ -0,0 +1,237 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. (macro #as m #refer #all) + lux) + (lux (control (functor #as F) + (monad #as M #refer (#only do))) + (data list))) + +## [Utils] +(def (first xy) + (All [a b] (-> (, a b) a)) + (let [[x y] xy] + x)) + +## Types +(deftype #export (Parser a) + (-> (List Syntax) (Maybe (, (List Syntax) a)))) + +## Structures +(defstruct #export Parser:Functor (F;Functor Parser) + (def (F;map f ma) + (lambda [tokens] + (case (ma tokens) + #;None + #;None + + (#;Some [tokens' a]) + (#;Some [tokens' (f a)]))))) + +(defstruct #export Parser:Monad (M;Monad Parser) + (def M;_functor Parser:Functor) + + (def (M;wrap x tokens) + (#;Some [tokens x])) + + (def (M;join mma) + (lambda [tokens] + (case (mma tokens) + #;None + #;None + + (#;Some [tokens' ma]) + (ma tokens'))))) + +## Parsers +(def #export (id^ tokens) + (Parser Syntax) + (case tokens + #;Nil #;None + (#;Cons [t tokens']) (#;Some [tokens' t]))) + +(do-template [ ] + [(def #export ( tokens) + (Parser ) + (case tokens + (#;Cons [(#;Meta [_ ( x)]) tokens']) + (#;Some [tokens' x]) + + _ + #;None))] + + [ bool^ Bool #;BoolS] + [ int^ Int #;IntS] + [ real^ Real #;RealS] + [ char^ Char #;CharS] + [ text^ Text #;TextS] + [symbol^ Ident #;SymbolS] + [ tag^ Ident #;TagS] + ) + +(def (bool:= x y) + (-> Bool Bool Bool) + (if x + y + (not y))) + +(def (ident:= x y) + (-> Ident Ident Bool) + (let [[x1 x2] x + [y1 y2] y] + (and (text:= x1 y1) + (text:= x2 y2)))) + +(do-template [ ] + [(def #export ( v tokens) + (-> (Parser (,))) + (case tokens + (#;Cons [(#;Meta [_ ( x)]) tokens']) + (if ( v x) + (#;Some [tokens' []]) + #;None) + + _ + #;None))] + + [ bool?^ Bool #;BoolS bool:=] + [ int?^ Int #;IntS int:=] + [ real?^ Real #;RealS real:=] + ## [ char?^ Char #;CharS char:=] + [ text?^ Text #;TextS text:=] + [symbol?^ Ident #;SymbolS ident:=] + [ tag?^ Ident #;TagS ident:=] + ) + +(do-template [ ] + [(def #export ( p tokens) + (All [a] + (-> (Parser a) (Parser a))) + (case tokens + (#;Cons [(#;Meta [_ ( form)]) tokens']) + (case (p form) + (#;Some [#;Nil x]) (#;Some [tokens' x]) + _ #;None) + + _ + #;None))] + + [ form^ #;FormS] + [tuple^ #;TupleS] + ) + +(def #export (?^ p tokens) + (All [a] + (-> (Parser a) (Parser (Maybe a)))) + (case (p tokens) + #;None (#;Some [tokens #;None]) + (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)]))) + +(def (run-parser p tokens) + (All [a] + (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a)))) + (p tokens)) + +(def #export (*^ p tokens) + (All [a] + (-> (Parser a) (Parser (List a)))) + (case (p tokens) + #;None (#;Some [tokens (list)]) + (#;Some [tokens' x]) (run-parser (do Parser:Monad + [xs (*^ p)] + (M;wrap (list& x xs))) + tokens'))) + +(def #export (+^ p) + (All [a] + (-> (Parser a) (Parser (List a)))) + (do Parser:Monad + [x p + xs (*^ p)] + (M;wrap (list& x xs)))) + +(def #export (&^ p1 p2) + (All [a b] + (-> (Parser a) (Parser b) (Parser (, a b)))) + (do Parser:Monad + [x1 p1 + x2 p2] + (M;wrap [x1 x2]))) + +(def #export (|^ p1 p2 tokens) + (All [a b] + (-> (Parser a) (Parser b) (Parser (Either b)))) + (case (p1 tokens) + (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) + #;None (run-parser (do Parser:Monad + [x2 p2] + (M;wrap (#;Right x2))) + tokens))) + +(def #export (||^ ps tokens) + (All [a] + (-> (List (Parser a)) (Parser (Maybe a)))) + (case ps + #;Nil #;None + (#;Cons [p ps']) (case (p tokens) + #;None (||^ ps' tokens) + (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)])) + )) + +(def #export (end^ tokens) + (Parser (,)) + (case tokens + #;Nil (#;Some [tokens []]) + _ #;None)) + +## Syntax +(defmacro #export (defsyntax tokens) + (case tokens + (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) + body)) + (do Lux:Monad + [names+parsers (M;map% Lux:Monad + (: (-> Syntax (Lux (, Syntax Syntax))) + (lambda [arg] + (case arg + (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) + parser))])) + (M;wrap [(symbol$ var-name) parser]) + + _ + (fail "Syntax pattern expects 2-tuples.")))) + args) + g!tokens (gensym "tokens") + #let [names (:: F;List:Functor (F;map first names+parsers)) + error-msg (text$ (text:++ "Wrong syntax for " name)) + parsing (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body name+parser] + (let [[name parser] name+parser] + (` (_lux_case ((~ parser) (~ g!tokens)) + (#;Some [(~ g!tokens) (~ name)]) + (~ body) + + _ + #;None))))) + (: Syntax (` (#;Some [(~@ names)]))) + (reverse names+parsers)) + body' (: Syntax + (` (_lux_case (~ parsing) + (#;Some [#;Nil [(~@ names)]]) + (~ body) + + _ + (l;fail (~ (text$ (text:++ "Wrong syntax for " name))))))) + macro-def (: Syntax + (` (m/defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) + (~ body'))))]] + (M;wrap (list macro-def))) + + _ + (fail "Wrong syntax for defsyntax"))) diff --git a/input/program.lux b/input/program.lux index 4f329c3fa..6495854c1 100644 --- a/input/program.lux +++ b/input/program.lux @@ -1,15 +1,28 @@ -(;lux) - -(def (filter p xs) - (All [a] (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - (list) - - (#;Cons [x xs']) - (if (p x) - (list& x (filter p xs')) - (filter p xs')))) +(;import lux + (lux (control monoid + functor + monad + lazy + comonad) + (data eq + bounded + ord + io + list + state + number + (text #as t) + dict + show) + (codata (stream #refer (#except iterate))) + (meta lux + macro + syntax))) (_jvm_program args - (println "Hello, world!")) + (case args + #;Nil + (println "Hello, world!") + + (#;Cons [name _]) + (println ($ text:++ "Hello, " name "!")))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 039db810a..8c8be29d2 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -115,6 +115,12 @@ ["lux;Nil" _]]]]]]] (&&lux/analyse-export analyse ?ident) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] + ["lux;Nil" _]]]]]]]]] + (&&lux/analyse-alias analyse ?alias ?module) + [_] (fail ""))) @@ -447,7 +453,7 @@ ;; Programs [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?args]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-program analyse ?args ?body) @@ -500,6 +506,9 @@ [["lux;Right" [state* output]]] (return* state* output) + [["lux;Left" ""]] + (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + [["lux;Left" msg]] (fail* (add-loc meta msg))) @@ -522,6 +531,21 @@ (fail* (add-loc meta msg)) )))) +(defn ^:private just-analyse [analyse-ast eval! compile-module syntax] + (&type/with-var + (fn [?var] + (|do [[?output-term ?output-type] (&&/analyse-1 (partial analyse-ast eval! compile-module) ?var syntax)] + (matchv ::M/objects [?var ?output-type] + [["lux;VarT" ?e-id] ["lux;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 (&/T ?output-term ?output-type))) + )))) + (defn ^:private analyse-ast [eval! compile-module exo-type token] (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] @@ -530,10 +554,12 @@ [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] (fn [state] - (matchv ::M/objects [((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state)] + (matchv ::M/objects [((just-analyse analyse-ast eval! compile-module ?fn) state) + ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) + ] [["lux;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) exo-type =fn ?args) state*)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type =fn ?args) state*)) [_] ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 43e5ee5e7..6efe7fd5f 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -15,6 +15,15 @@ (fail "##9##")))] (resolve-type type*)) + [["lux;AllT" ?id]] + (|do [$var &type/existential + =type (&type/apply-type type $var)] + (&type/actual-type =type)) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [=type (&type/apply-type type $var)] + ;; (&type/actual-type =type)))) + [_] (&type/actual-type type))) @@ -68,7 +77,7 @@ (return (&/T (&/V "TupleTestAC" =tests) =kont)))) [_] - (fail "[Analyser Error] Tuple requires tuple-type.")) + (fail "[Analyser Error] Tuples require tuple-type.")) [["lux;RecordS" ?slots]] (|do [value-type* (resolve-type value-type)] diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index fa7b9aa1a..de6bdb036 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -16,18 +16,20 @@ =return (body (&/update$ &/$ENVS (fn [stack] (let [bound-unit (&/V "lux;Local" (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))] - (&/|cons (->> (&/|head stack) - (&/update$ &/$LOCALS #(&/update$ &/$COUNTER inc %)) - (&/update$ &/$LOCALS #(&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)) %))) + (&/|cons (&/update$ &/$LOCALS #(->> % + (&/update$ &/$COUNTER inc) + (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) + (&/|head stack)) (&/|tail stack)))) state))] (matchv ::M/objects [=return] [["lux;Right" [?state ?value]]] (return* (&/update$ &/$ENVS (fn [stack*] - (&/|cons (->> (&/|head stack*) - (&/update$ &/$LOCALS #(&/update$ &/$COUNTER dec %)) - (&/update$ &/$LOCALS #(&/set$ &/$MAPPINGS old-mappings %))) - (&/|tail stack*))) + (&/|cons (&/update$ &/$LOCALS #(->> % + (&/update$ &/$COUNTER dec) + (&/set$ &/$MAPPINGS old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) ?state) ?value) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index b9361b8c3..3db4bd16d 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -352,7 +352,8 @@ ) (defn analyse-jvm-program [analyse ?args ?body] - (|do [=body (&/with-scope "" - (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))] - (return (&/|list (&/V "jvm-program" =body))))) + (|let [[_module _name] ?args] + (|do [=body (&/with-scope "" + (&&env/with-local (str _module ";" _name) (&/V "lux;AppT" (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))] + (return (&/|list (&/V "jvm-program" =body)))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 6bbcd0fcf..d02599f10 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -76,6 +76,15 @@ (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) + [["lux;AllT" _]] + (|do [$var &type/existential + =type (&type/apply-type exo-type $var)] + (&type/actual-type =type)) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [=type (&type/apply-type exo-type $var)] + ;; (&type/actual-type =type)))) + [_] (&type/actual-type exo-type)) types (matchv ::M/objects [exo-type*] @@ -83,7 +92,9 @@ (return ?table) [_] - (fail "[Analyser Error] The type of a record must be a record type.")) + (fail (str "[Analyser Error] The type of a record must be a record type:\n" + (&type/show-type exo-type*) + "\n"))) =slots (&/map% (fn [kv] (matchv ::M/objects [kv] [[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]] @@ -196,6 +207,9 @@ (|do [?fun-type* (&type/actual-type fun-type)] (matchv ::M/objects [?fun-type*] [["lux;AllT" _]] + ;; (|do [$var &type/existential + ;; type* (&type/apply-type ?fun-type* $var)] + ;; (analyse-apply* analyse exo-type type* ?args)) (&type/with-var (fn [$var] (|do [type* (&type/apply-type ?fun-type* $var) @@ -216,6 +230,9 @@ =arg (&&/analyse-1 analyse ?input-t ?arg)] (return (&/T =output-t (&/|cons =arg =args)))) + ;; [["lux;VarT" ?id-t]] + ;; (|do [ (&type/deref ?id-t)]) + [_] (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) )) @@ -229,7 +246,14 @@ (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] (matchv ::M/objects [$def] [["lux;MacroD" macro]] - (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))] + (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) + :let [_ (when (and ;; (= "lux/control/monad" ?module) + (= "do" ?name)) + (->> (&/|map &/show-ast macro-expansion) + (&/|interpose "\n") + (&/fold str "") + (prn ?module "do")))] + ] (&/flat-map% (partial analyse exo-type) macro-expansion)) [_] @@ -254,16 +278,26 @@ exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] - (matchv ::M/objects [exo-type] - [["lux;LambdaT" [?arg-t ?return-t]]] - (|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))) - - [_] - (fail (str "[Analyser Error] Functions require function types: " - (&type/show-type exo-type))))) + (|do [exo-type* (&type/actual-type exo-type)] + (matchv ::M/objects [exo-type] + [["lux;AllT" _]] + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-lambda* analyse exo-type** ?self ?arg ?body)))) + ;; (|do [$var &type/existential + ;; exo-type** (&type/apply-type exo-type* $var)] + ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) + + [["lux;LambdaT" [?arg-t ?return-t]]] + (|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*))) + + [_] + (fail (str "[Analyser Error] Functions require function types: " + (&type/show-type exo-type*)))))) (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] (matchv ::M/objects [exo-type] @@ -281,6 +315,14 @@ [["lux;ExT" _]] (return (&/T _expr exo-type)) + [["lux;VarT" ?_id]] + (|do [?? (&type/bound? ?_id)] + ;; (return (&/T _expr exo-type)) + (if ?? + (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) + (return (&/T _expr exo-type))) + ) + [_] (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) (return (&/T _expr exo-type)))))))) @@ -295,7 +337,7 @@ (return (&/|list output)))) (defn analyse-def [analyse ?name ?value] - (prn 'analyse-def/BEGIN ?name) + ;; (prn 'analyse-def/BEGIN ?name) (|do [module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? @@ -306,14 +348,16 @@ (matchv ::M/objects [=value] [[["lux;Global" [?r-module ?r-name]] _]] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) - :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) - _ (println)]] + ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) + ;; _ (println)] + ] (return (&/|list))) [_] (|do [=value-type (&&/expr-type =value) - :let [_ (prn 'analyse-def/END ?name) - _ (println) + :let [;; _ (prn 'analyse-def/END ?name) + _ (println 'DEF (str module-name ";" ?name)) + ;; _ (println) def-data (cond (&type/type= &type/Type =value-type) (&/V "lux;TypeD" nil) @@ -328,23 +372,32 @@ (return (&/|list (&/V "declare-macro" (&/T module-name ?name)))))) (defn analyse-import [analyse compile-module ?path] - (prn 'analyse-import ?path) - (fn [state] - (let [already-compiled? (&/fold false #(or %1 (= %2 ?path)) (&/get$ &/$SEEN-SOURCES state))] - (&/run-state (|do [_ (&&module/add-import ?path) - _ (if already-compiled? - (return nil) - (compile-module ?path))] - (return (&/|list))) - (if already-compiled? - state - (&/update$ &/$SEEN-SOURCES (partial &/|cons ?path) state)))))) + (|do [module-name &/get-module-name] + (if (= module-name ?path) + (fail (str "[Analyser Error] Module can't import itself: " ?path)) + (&/save-module + (fn [state] + (let [already-compiled? (&/fold #(or %1 (= %2 ?path)) false (&/get$ &/$SEEN-SOURCES state))] + (prn 'analyse-import module-name ?path already-compiled?) + (&/run-state (|do [_ (&&module/add-import ?path) + _ (if already-compiled? + (return nil) + (compile-module ?path))] + (return (&/|list))) + (if already-compiled? + state + (&/update$ &/$SEEN-SOURCES (partial &/|cons ?path) state))))))))) (defn analyse-export [analyse name] (|do [module-name &/get-module-name _ (&&module/export module-name name)] (return (&/|list)))) +(defn analyse-alias [analyse ex-alias ex-module] + (|do [module-name &/get-module-name + _ (&&module/alias module-name ex-alias ex-module)] + (return (&/|list)))) + (defn analyse-check [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index f0e5b82b4..27aa7374c 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -1,5 +1,6 @@ (ns lux.analyser.module - (:require [clojure.core.match :as M :refer [matchv]] + (:require [clojure.string :as string] + [clojure.core.match :as M :refer [matchv]] clojure.core.match.array (lux [base :as & :refer [|let |do return return* fail fail*]] [type :as &type] @@ -46,13 +47,14 @@ #(&/|put name (&/T false def-data) %) m)) ms))) - (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] - (&/update$ &/$MAPPINGS (fn [mappings] - (&/|put (str "" &/+name-separator+ name) - (&/T (&/V "lux;Global" (&/T module name)) type) - mappings)) - locals)) - ?env)))) + ;; (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] + ;; (&/update$ &/$MAPPINGS (fn [mappings] + ;; (&/|put (str "" &/+name-separator+ name) + ;; (&/T (&/V "lux;Global" (&/T module name)) type) + ;; mappings)) + ;; locals)) + ;; ?env))) + ) nil) [_] @@ -93,14 +95,15 @@ #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %) m)) ms))) - (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] - (&/update$ &/$MAPPINGS (fn [mappings] - (&/|put (str "" &/+name-separator+ a-name) - (&/T (&/V "lux;Global" (&/T r-module r-name)) type) - ;; (aget (->> state (&/get$ &/$MODULES) (&/|get r-module) (&/get$ $DEFS) (&/|get r-name)) 1) - mappings)) - locals)) - ?env)))) + ;; (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] + ;; (&/update$ &/$MAPPINGS (fn [mappings] + ;; (&/|put (str "" &/+name-separator+ a-name) + ;; (&/T (&/V "lux;Global" (&/T r-module r-name)) type) + ;; ;; (aget (->> state (&/get$ &/$MODULES) (&/|get r-module) (&/get$ $DEFS) (&/|get r-name)) 1) + ;; mappings)) + ;; locals)) + ;; ?env))) + ) nil) [_] @@ -112,7 +115,7 @@ (return* state (->> state (&/get$ &/$MODULES) (&/|contains? name))))) -(defn alias-module [module reference alias] +(defn alias [module alias reference] (fn [state] (return* (->> state (&/update$ &/$MODULES @@ -136,23 +139,23 @@ (|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) (&/get$ $DEFS))] + (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (&/|get name $module)] - (matchv ::M/objects [$def] - [[exported? $$def]] - (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) - (if (or exported? (.equals ^Object current-module module)) - (matchv ::M/objects [$$def] - [["lux;AliasD" [?r-module ?r-name]]] - (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) - ((find-def ?r-module ?r-name) - state)) - - [_] - (return* state (&/T (&/T module name) $$def))) - (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) - (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name))))) + (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] + (matchv ::M/objects [$def] + [[exported? $$def]] + (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) + (if (or exported? (.equals ^Object current-module module)) + (matchv ::M/objects [$$def] + [["lux;AliasD" [?r-module ?r-name]]] + (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) + ((find-def ?r-module ?r-name) + state)) + + [_] + (return* state (&/T (&/T module name) $$def))) + (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) + (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) (do (prn [module name] (str "[Analyser Error] Module doesn't exist: " module) (->> state (&/get$ &/$MODULES) &/|keys &/->seq)) @@ -171,7 +174,7 @@ [[exported? ["lux;ValueD" ?type]]] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (str module ".$" (&/normalize-ident name))) + :let [macro (-> (.loadClass loader (str (string/replace module #"/" ".") ".$" (&/normalize-ident name))) (.getField "_datum") (.get nil))]] (fn [state*] @@ -191,9 +194,9 @@ (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) [[_ ["lux;TypeD" _]]] - (fail* (str "[Analyser Error] Definition doesn't have macro type: " module ";" name))) - (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name)))) - (fail* (str "[Analyser Error] Module doesn't exist: " module))))) + (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name)))) + (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) + (fail* (str "[Analyser Error] Module does not exist: " module))))) (defn export [module name] (fn [state] @@ -213,7 +216,7 @@ m)) ms)))) nil)) - (fail* (str "[Analyser Error] Can't export an inexistent definition: " module ";" name))) + (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) [_] (fail* "[Analyser Error] Can't export a global definition outside of a global environment.")))) diff --git a/src/lux/base.clj b/src/lux/base.clj index aecb3fd13..d88bb2ec1 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -483,13 +483,25 @@ ;; "lux;seed" 0 ;; "lux;seen-sources" - (|list) + (|list "lux") ;; "lux;source" (V "lux;None" nil) ;; "lux;types" +init-bindings+ )) +(defn save-module [body] + (fn [state] + (matchv ::M/objects [(body state)] + [["lux;Right" [state* output]]] + (return* (->> state* + (set$ $ENVS (get$ $ENVS state)) + (set$ $SOURCE (get$ $SOURCE state))) + output) + + [["lux;Left" msg]] + (fail* msg)))) + (defn with-eval [body] (fn [state] (matchv ::M/objects [(body (set$ $EVAL? true state))] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 1970c548a..04f4fb4c2 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -342,7 +342,7 @@ .visitEnd))] _ (&&/save-class! (str id) bytecode) loader &/loader] - (-> (.loadClass ^ClassLoader loader (str module "." id)) + (-> (.loadClass ^ClassLoader loader (str (string/replace module #"/" ".") "." id)) (.getField "_eval") (.get nil) return)))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index bc1ab23f1..2a8bdac89 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -146,7 +146,7 @@ compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I" ) -(do-template [ ] +(do-template [ ] (defn [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer @@ -162,25 +162,26 @@ $end (new Label) _ (doto *writer* (.visitInsn ) - (.visitJumpInsn $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) + (.visitLdcInsn (int )) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) (.visitJumpInsn Opcodes/GOTO $end) (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) (.visitLabel $end))]] (return nil))) - compile-jvm-leq Opcodes/LCMP Opcodes/IFEQ "java.lang.Long" "longValue" "()J" - compile-jvm-llt Opcodes/LCMP Opcodes/IFLT "java.lang.Long" "longValue" "()J" - compile-jvm-lgt Opcodes/LCMP Opcodes/IFGT "java.lang.Long" "longValue" "()J" + compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" + compile-jvm-llt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J" + compile-jvm-lgt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" - compile-jvm-feq Opcodes/FCMPG Opcodes/IFEQ "java.lang.Float" "floatValue" "()F" - compile-jvm-flt Opcodes/FCMPG Opcodes/IFLT "java.lang.Float" "floatValue" "()F" - compile-jvm-fgt Opcodes/FCMPG Opcodes/IFGT "java.lang.Float" "floatValue" "()F" + compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F" + compile-jvm-flt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F" + compile-jvm-fgt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F" - compile-jvm-deq Opcodes/DCMPG Opcodes/IFEQ "java.lang.Double" "doubleValue" "()I" - compile-jvm-dlt Opcodes/DCMPG Opcodes/IFLT "java.lang.Double" "doubleValue" "()I" - compile-jvm-dgt Opcodes/FCMPG Opcodes/IFGT "java.lang.Double" "doubleValue" "()I" + compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()I" + compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()I" + compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()I" ) (defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index ecb614732..7d6b2b502 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -25,6 +25,17 @@ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) +(defn compile-int [compile *type* value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW "java/lang/Long") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (bit-shift-left (long value) 0) + ;; (bit-shift-left (long value) 32) + ) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Long" "" "(J)V"))]] + (return nil))) + (do-template [ ] (defn [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer @@ -35,7 +46,7 @@ (.visitMethodInsn Opcodes/INVOKESPECIAL "" ))]] (return nil))) - compile-int "java/lang/Long" "(J)V" long + ;; compile-int "java/lang/Long" "(J)V" long compile-real "java/lang/Double" "(D)V" double compile-char "java/lang/Character" "(C)V" char ) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index a137ca863..fbfe1f757 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -67,8 +67,8 @@ (return (&/V "lux;Meta" (&/T meta (&/V token)))))) ^:private lex-bool "Bool" #"^(true|false)" - ^:private lex-int "Int" #"^-?(0|[1-9][0-9]*)" - ^:private lex-real "Real" #"^-?(0|[1-9][0-9]*)\.[0-9]+" + ^:private lex-int "Int" #"^(-?0|-?[1-9][0-9]*)" + ^:private lex-real "Real" #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)" ) (def ^:private lex-char @@ -89,14 +89,14 @@ (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] (&/try-all% (&/|list (|do [_ (&reader/read-text ";") - [_ local-token] (&reader/read-regex +ident-re+)] - (&/try-all% (&/|list (|do [unaliased (&module/dealias token)] - (return (&/T meta (&/T unaliased local-token)))) - (|do [? (&module/exists? token)] - (if ? - (return (&/T meta (&/T token local-token))) - (fail (str "[Lexer Error] Unknown module: " token)))) - ))) + [_ local-token] (&reader/read-regex +ident-re+) + ? (&module/exists? token)] + (if ? + (return (&/T meta (&/T token local-token))) + (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) + (&module/dealias token))] + (do ;; (prn "Unaliased: " unaliased ";" local-token) + (return (&/T meta (&/T unaliased local-token))))))) (return (&/T meta (&/T "" token))) ))) (|do [[meta _] (&reader/read-text ";;") diff --git a/src/lux/type.clj b/src/lux/type.clj index e0315f8e7..e7d6353e8 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -349,16 +349,18 @@ (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) [["lux;VariantT" cases]] - (str "(| " (->> cases - (&/|map (fn [kv] - (matchv ::M/objects [kv] - [[k ["Tuple" ["Nil" _]]]] - (str "#" k) - - [[k v]] - (str "(#" k " " (show-type v) ")")))) - (&/|interpose " ") - (&/fold str "")) ")") + (if (&/|empty? cases) + "(|)" + (str "(| " (->> cases + (&/|map (fn [kv] + (matchv ::M/objects [kv] + [[k ["lux;TupleT" ["lux;Nil" _]]]] + (str "#" k) + + [[k v]] + (str "(#" k " " (show-type v) ")")))) + (&/|interpose " ") + (&/fold str "")) ")")) [["lux;RecordT" fields]] @@ -485,7 +487,9 @@ (&/|cons (&/T k v) fixpoints)) (defn ^:private check-error [expected actual] - (str "Type " (show-type expected) " does not subsume type " (show-type actual))) + (str "[Type Checker]\nExpected: " (show-type expected) + "\n\nActual: " (show-type actual) + "\n")) (defn beta-reduce [env type] (matchv ::M/objects [type] @@ -555,7 +559,7 @@ (apply-type type-fn* param)) [_] - (fail (str "[Type System] Can't apply type function " (show-type type-fn) " to type " (show-type param))))) + (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) (def init-fixpoints (&/|list)) @@ -826,10 +830,10 @@ [["lux;ExT" e!id] ["lux;ExT" a!id]] (if (.equals ^Object e!id a!id) (return (&/T fixpoints nil)) - (check-error expected actual)) + (fail (check-error expected actual))) [_ _] - (fail (println-str "[Type Error] Can't type-check: " (show-type expected) (show-type actual))) + (fail (check-error expected actual)) ))) (defn check [expected actual] @@ -850,7 +854,7 @@ (clean $var =return)))) [_] - (fail (str "[Type System] Can't apply type " (show-type func) " to type " (show-type param))) + (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] @@ -859,6 +863,9 @@ (|do [type* (apply-type ?all ?param)] (actual-type type*)) + [["lux;VarT" ?id]] + (deref ?id) + [_] (return type) )) -- cgit v1.2.3 From eb424eeb33d8fc9bb7ad2acda0c58fcb037717d3 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 14 Jul 2015 22:47:10 -0400 Subject: - Added a ' (quote) macro that works like ` (backquote), without unquote or unquote splice working and not automatic prefixing of unprefixed symbols/tags. - Added (slightly) better type-error messages. --- input/lux.lux | 88 +++++++++++++++++++++++------------------- src/lux/analyser/case.clj | 2 +- src/lux/type.clj | 97 +++++++++++++++++++++++++++++++++++++++++------ 3 files changed, 137 insertions(+), 50 deletions(-) diff --git a/input/lux.lux b/input/lux.lux index de407bafe..2bad33439 100644 --- a/input/lux.lux +++ b/input/lux.lux @@ -791,48 +791,52 @@ _ (fail "Wrong syntax for $"))) -(def'' (splice untemplate tag elems) - (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) - (_lux_case (any? spliced? elems) +(def'' (splice replace? untemplate tag elems) + (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) + (_lux_case replace? true - (let [elems' (map (lambda [elem] - (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced - - _ - (form$ (list (symbol$ ["" "_lux_:"]) - (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) - (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) - (tag$ ["lux" "Nil"]))))))))) - elems)] - (wrap-meta (form$ (list tag - (form$ (list& (symbol$ ["lux" "$"]) - (symbol$ ["lux" "list:++"]) - elems')))))) - + (_lux_case (any? spliced? elems) + true + (let [elems' (map (lambda [elem] + (_lux_case elem + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced + + _ + (form$ (list (symbol$ ["" "_lux_:"]) + (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) + (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) + (tag$ ["lux" "Nil"]))))))))) + elems)] + (wrap-meta (form$ (list tag + (form$ (list& (symbol$ ["lux" "$"]) + (symbol$ ["lux" "list:++"]) + elems')))))) + + false + (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))) false (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) -(def'' (untemplate subst token) - (->' Text Syntax Syntax) - (_lux_case token - (#Meta [_ (#BoolS value)]) +(def'' (untemplate replace? subst token) + (->' Bool Text Syntax Syntax) + (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token]) + [_ (#Meta [_ (#BoolS value)])] (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) - (#Meta [_ (#IntS value)]) + [_ (#Meta [_ (#IntS value)])] (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) - (#Meta [_ (#RealS value)]) + [_ (#Meta [_ (#RealS value)])] (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) - (#Meta [_ (#CharS value)]) + [_ (#Meta [_ (#CharS value)])] (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) - (#Meta [_ (#TextS value)]) + [_ (#Meta [_ (#TextS value)])] (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) - (#Meta [_ (#TagS [module name])]) + [_ (#Meta [_ (#TagS [module name])])] (let [module' (_lux_case module "" subst @@ -841,7 +845,7 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) - (#Meta [_ (#SymbolS [module name])]) + [_ (#Meta [_ (#SymbolS [module name])])] (let [module' (_lux_case module "" subst @@ -850,32 +854,40 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) - (#Meta [_ (#TupleS elems)]) - (splice (untemplate subst) (tag$ ["lux" "TupleS"]) elems) + [_ (#Meta [_ (#TupleS elems)])] + (splice (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))]) + [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] unquoted - (#Meta [_ (#FormS elems)]) - (splice (untemplate subst) (tag$ ["lux" "FormS"]) elems) + [_ (#Meta [_ (#FormS elems)])] + (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) - (#Meta [_ (#RecordS fields)]) + [_ (#Meta [_ (#RecordS fields)])] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) (lambda [kv] (let [[k v] kv] - (tuple$ (list (untemplate subst k) (untemplate subst v)))))) + (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) fields))))) )) (defmacro (`' tokens) (_lux_case tokens (#Cons [template #Nil]) - (return (list (untemplate "" template))) + (return (list (untemplate true "" template))) _ (fail "Wrong syntax for `'"))) +(defmacro (' tokens) + (_lux_case tokens + (#Cons [template #Nil]) + (return (list (untemplate false "" template))) + + _ + (fail "Wrong syntax for '"))) + (defmacro #export (|> tokens) (_lux_case tokens (#Cons [init apps]) @@ -1648,7 +1660,7 @@ [module-name get-module-name] (case tokens (\ (list template)) - (;return (list (untemplate module-name template))) + (;return (list (untemplate true module-name template))) _ (fail "Wrong syntax for `")))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 6efe7fd5f..6dfa234bd 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -77,7 +77,7 @@ (return (&/T (&/V "TupleTestAC" =tests) =kont)))) [_] - (fail "[Analyser Error] Tuples require tuple-type.")) + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type value-type)))) [["lux;RecordS" ?slots]] (|do [value-type* (resolve-type value-type)] diff --git a/src/lux/type.clj b/src/lux/type.clj index e7d6353e8..c3a27ce2b 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -338,6 +338,15 @@ [_] (fail (str "[Type Error] Not type-var: " (show-type tvar))))) +(defn ^:private unravel-app [fun-type] + (matchv ::M/objects [fun-type] + [["lux;AppT" [?left ?right]]] + (|let [[?fun-type ?args] (unravel-app ?left)] + (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) + + [_] + (&/T fun-type (&/|list)))) + (defn show-type [^objects type] (matchv ::M/objects [type] [["lux;DataT" name]] @@ -384,23 +393,89 @@ [["lux;ExT" ?id]] (str "⟨" ?id "⟩") - [["lux;AppT" [?lambda ?param]]] - (str "(" (show-type ?lambda) " " (show-type ?param) ")") + [["lux;AppT" [_ _]]] + (|let [[?call-fun ?call-args] (unravel-app type)] + (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) [["lux;AllT" [?env ?name ?arg ?body]]] - (let [[args body] (loop [args (list ?arg) - body* ?body] - (matchv ::M/objects [body*] - [["lux;AllT" [?env* ?name* ?arg* ?body*]]] - (recur (cons ?arg* args) ?body*) - - [_] - [args body*]))] - (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) + (if (= "" ?name) + (let [[args body] (loop [args (list ?arg) + body* ?body] + (matchv ::M/objects [body*] + [["lux;AllT" [?env* ?name* ?arg* ?body*]]] + (recur (cons ?arg* args) ?body*) + + [_] + [args body*]))] + (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) + ?name) [_] (assert false (prn-str 'show-type (aget type 0) (class (aget type 1)))) )) +;; (defn show-type [^objects type] +;; (matchv ::M/objects [type] +;; [["lux;DataT" name]] +;; (str "(^ " name ")") + +;; [["lux;TupleT" elems]] +;; (if (&/|empty? elems) +;; "(,)" +;; (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) + +;; [["lux;VariantT" cases]] +;; (if (&/|empty? cases) +;; "(|)" +;; (str "(| " (->> cases +;; (&/|map (fn [kv] +;; (matchv ::M/objects [kv] +;; [[k ["lux;TupleT" ["lux;Nil" _]]]] +;; (str "#" k) + +;; [[k v]] +;; (str "(#" k " " (show-type v) ")")))) +;; (&/|interpose " ") +;; (&/fold str "")) ")")) + + +;; [["lux;RecordT" fields]] +;; (str "(& " (->> fields +;; (&/|map (fn [kv] +;; (matchv ::M/objects [kv] +;; [[k v]] +;; (str "#" k " " (show-type v))))) +;; (&/|interpose " ") +;; (&/fold str "")) ")") + +;; [["lux;LambdaT" [input output]]] +;; (str "(-> " (show-type input) " " (show-type output) ")") + +;; [["lux;VarT" id]] +;; (str "⌈" id "⌋") + +;; [["lux;BoundT" name]] +;; name + +;; [["lux;ExT" ?id]] +;; (str "⟨" ?id "⟩") + +;; [["lux;AppT" [?lambda ?param]]] +;; (str "(" (show-type ?lambda) " " (show-type ?param) ")") + +;; [["lux;AllT" [?env ?name ?arg ?body]]] +;; (let [[args body] (loop [args (list ?arg) +;; body* ?body] +;; (matchv ::M/objects [body*] +;; [["lux;AllT" [?env* ?name* ?arg* ?body*]]] +;; (recur (cons ?arg* args) ?body*) + +;; [_] +;; [args body*]))] +;; (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) + +;; [_] +;; (assert false (prn-str 'show-type (aget type 0) (class (aget type 1)))) +;; )) (defn type= [x y] (or (clojure.lang.Util/identical x y) -- cgit v1.2.3 From 50366bad3ecf961fdfdbb1e4d8436794d97ae763 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 19 Jul 2015 22:24:48 -0400 Subject: - Some bug fixes. - More additions to the standard library. --- .gitignore | 2 + input/lux.lux | 293 +++++++++++---------- input/lux/codata/stream.lux | 160 ++++++++---- input/lux/control/functor.lux | 22 +- input/lux/control/lazy.lux | 6 +- input/lux/control/monad.lux | 80 +++--- input/lux/control/monoid.lux | 35 +-- input/lux/data/bounded.lux | 4 +- input/lux/data/dict.lux | 2 +- input/lux/data/either.lux | 46 ++++ input/lux/data/eq.lux | 13 +- input/lux/data/error.lux | 34 +++ input/lux/data/id.lux | 28 ++ input/lux/data/io.lux | 6 +- input/lux/data/list.lux | 48 +++- input/lux/data/maybe.lux | 42 +++ input/lux/data/number.lux | 86 +++++-- input/lux/data/ord.lux | 25 +- input/lux/data/reader.lux | 33 +++ input/lux/data/show.lux | 10 +- input/lux/data/state.lux | 26 +- input/lux/data/text.lux | 52 ++-- input/lux/data/writer.lux | 34 +++ input/lux/host/java.lux | 311 +++++++++++++++++++++++ input/lux/math.lux | 60 +++++ input/lux/meta/lux.lux | 155 +++++++++-- input/lux/meta/syntax.lux | 119 +++++---- input/program.lux | 30 ++- src/lux/analyser.clj | 578 ++++++++++++++++++++---------------------- src/lux/analyser/case.clj | 70 ++--- src/lux/analyser/host.clj | 26 +- src/lux/analyser/lux.clj | 10 +- src/lux/base.clj | 12 +- src/lux/compiler.clj | 13 + src/lux/compiler/host.clj | 24 +- src/lux/compiler/lux.clj | 13 +- 36 files changed, 1683 insertions(+), 825 deletions(-) create mode 100644 input/lux/data/either.lux create mode 100644 input/lux/data/error.lux create mode 100644 input/lux/data/id.lux create mode 100644 input/lux/data/maybe.lux create mode 100644 input/lux/data/reader.lux create mode 100644 input/lux/data/writer.lux create mode 100644 input/lux/host/java.lux create mode 100644 input/lux/math.lux diff --git a/.gitignore b/.gitignore index fdc7212fc..9c8887842 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,5 @@ pom.xml.asc LICENSE README.md doc/intro.md +/jbe + diff --git a/input/lux.lux b/input/lux.lux index 2bad33439..0c8b73c34 100644 --- a/input/lux.lux +++ b/input/lux.lux @@ -10,15 +10,6 @@ (_jvm_interface "Function" [] (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) -## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] -## [(foo "java.lang.Object" ["public" "static"])] -## ( [] "void" -## ["public"] -## (_jvm_invokespecial java.lang.Object [] this [])) -## (apply [(arg "java.lang.Object")] "java.lang.Object" -## ["public"] -## "YOLO")) - ## Basic types (_lux_def Bool (#DataT "java.lang.Boolean")) (_lux_export Bool) @@ -35,6 +26,9 @@ (_lux_def Text (#DataT "java.lang.String")) (_lux_export Text) +(_lux_def Unit (#TupleT #Nil)) +(_lux_export Unit) + (_lux_def Void (#VariantT #Nil)) (_lux_export Void) @@ -105,6 +99,7 @@ (#Cons [(#BoundT "v") #Nil])]))])] #Nil])]))])])) +(_lux_export Bindings) ## (deftype (Env k v) ## (& #name Text @@ -121,6 +116,7 @@ (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) (#BoundT "v")])] #Nil])])])]))])])) +(_lux_export Env) ## (deftype Cursor ## (, Text Int Int)) @@ -855,7 +851,7 @@ (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) [_ (#Meta [_ (#TupleS elems)])] - (splice (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) + (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] unquoted @@ -937,7 +933,7 @@ ($' (B' m) (B' a)) ($' (B' m) (B' b))))])))) -(def'' Maybe:Monad +(def'' Maybe/Monad ($' Monad Maybe) {#lux;return (lambda return [x] @@ -949,7 +945,7 @@ #None #None (#Some a) (f a)))}) -(def'' Lux:Monad +(def'' Lux/Monad ($' Monad Lux) {#lux;return (lambda [x] @@ -1126,8 +1122,8 @@ (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(map% Maybe:Monad get-ident bindings) - (map% Maybe:Monad tuple->list data)]) + [(map% Maybe/Monad get-ident bindings) + (map% Maybe/Monad tuple->list data)]) [(#Some bindings') (#Some data')] (let [apply (_lux_: (-> RepEnv ($' List Syntax)) (lambda [env] (map (apply-template env) templates)))] @@ -1146,12 +1142,12 @@ (-> Bool) ( x y))] - [int:= _jvm_leq Int] - [int:> _jvm_lgt Int] - [int:< _jvm_llt Int] - [real:= _jvm_deq Real] - [real:> _jvm_dgt Real] - [real:< _jvm_dlt Real] + [i= _jvm_leq Int] + [i> _jvm_lgt Int] + [i< _jvm_llt Int] + [r= _jvm_deq Real] + [r> _jvm_dgt Real] + [r< _jvm_dlt Real] ) (do-template [ ] @@ -1161,10 +1157,10 @@ true ( x y)))] - [ int:>= int:> int:= Int] - [ int:<= int:< int:= Int] - [real:>= real:> real:= Real] - [real:<= real:< real:= Real] + [i>= i> i= Int] + [i<= i< i= Int] + [r>= r> r= Real] + [r<= r< r= Real] ) (do-template [ ] @@ -1172,25 +1168,25 @@ (-> ) ( x y))] - [int:+ _jvm_ladd Int] - [int:- _jvm_lsub Int] - [int:* _jvm_lmul Int] - [int:/ _jvm_ldiv Int] - [int:% _jvm_lrem Int] - [real:+ _jvm_dadd Real] - [real:- _jvm_dsub Real] - [real:* _jvm_dmul Real] - [real:/ _jvm_ddiv Real] - [real:% _jvm_drem Real] + [i+ _jvm_ladd Int] + [i- _jvm_lsub Int] + [i* _jvm_lmul Int] + [i/ _jvm_ldiv Int] + [i% _jvm_lrem Int] + [r+ _jvm_dadd Real] + [r- _jvm_dsub Real] + [r* _jvm_dmul Real] + [r/ _jvm_ddiv Real] + [r% _jvm_drem Real] ) (def'' (multiple? div n) (-> Int Int Bool) - (int:= 0 (int:% n div))) + (i= 0 (i% n div))) (def'' (length list) (-> List Int) - (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) + (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) (def'' #export (not x) (-> Bool Bool) @@ -1244,7 +1240,7 @@ ["" tokens]))] (_lux_case tokens' (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe:Monad get-ident args) + (_lux_case (map% Maybe/Monad get-ident args) (#Some idents) (_lux_case idents #Nil @@ -1309,7 +1305,7 @@ (-> ($' List (, Text ($' Module Compiler))) Text Text Text ($' Maybe Macro)) - (do Maybe:Monad + (do Maybe/Monad [$module (get module modules) gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] (get name bindings))] @@ -1329,7 +1325,7 @@ (def'' (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) - (do Lux:Monad + (do Lux/Monad [current-module get-module-name] (let [[module name] ident] (lambda [state] @@ -1348,7 +1344,7 @@ (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] - (do Lux:Monad + (do Lux/Monad [module-name get-module-name] (;return (_lux_: Ident [module-name name]))) @@ -1356,18 +1352,18 @@ (return ident))) (defmacro #export (| tokens) - (do Lux:Monad - [pairs (map% Lux:Monad + (do Lux/Monad + [pairs (map% Lux/Monad (_lux_: (-> Syntax ($' Lux Syntax)) (lambda [token] (_lux_case token (#Meta [_ (#TagS ident)]) - (do Lux:Monad + (do Lux/Monad [ident (normalize ident)] (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) - (do Lux:Monad + (do Lux/Monad [ident (normalize ident)] (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) @@ -1379,13 +1375,13 @@ (defmacro #export (& tokens) (if (not (multiple? 2 (length tokens))) (fail "& expects an even number of arguments.") - (do Lux:Monad - [pairs (map% Lux:Monad + (do Lux/Monad + [pairs (map% Lux/Monad (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) (lambda [pair] (_lux_case pair [(#Meta [_ (#TagS ident)]) value] - (do Lux:Monad + (do Lux/Monad [ident (normalize ident)] (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) @@ -1415,30 +1411,30 @@ (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) - (do Lux:Monad + (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] (_lux_case ?macro (#Some macro) - (do Lux:Monad + (do Lux/Monad [expansion (macro args) - expansion' (map% Lux:Monad macro-expand expansion)] + expansion' (map% Lux/Monad macro-expand expansion)] (;return (list:join expansion'))) #None - (do Lux:Monad - [parts' (map% Lux:Monad macro-expand (list& (symbol$ macro-name) args))] + (do Lux/Monad + [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] (;return (list (form$ (list:join parts'))))))) (#Meta [_ (#FormS (#Cons [harg targs]))]) - (do Lux:Monad + (do Lux/Monad [harg+ (macro-expand harg) - targs+ (map% Lux:Monad macro-expand targs)] + targs+ (map% Lux/Monad macro-expand targs)] (;return (list (form$ (list:++ harg+ (list:join targs+)))))) (#Meta [_ (#TupleS members)]) - (do Lux:Monad - [members' (map% Lux:Monad macro-expand members)] + (do Lux/Monad + [members' (map% Lux/Monad macro-expand members)] (;return (list (tuple$ (list:join members'))))) _ @@ -1464,7 +1460,7 @@ (defmacro #export (type tokens) (_lux_case tokens (#Cons [type #Nil]) - (do Lux:Monad + (do Lux/Monad [type+ (macro-expand type)] (_lux_case type+ (#Cons [type' #Nil]) @@ -1494,12 +1490,12 @@ (defmacro #export (deftype tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens + (_lux_case (:! (List Syntax) tokens) (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] + [true (:! (List Syntax) tokens')] _ - [false tokens])) + [false (:! (List Syntax) tokens)])) parts (: (Maybe (, Syntax (List Syntax) Syntax)) (_lux_case tokens' (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) @@ -1597,20 +1593,20 @@ (defmacro #export (case tokens) (_lux_case tokens (#Cons [value branches]) - (do Lux:Monad - [expansions (map% Lux:Monad + (do Lux/Monad + [expansions (map% Lux/Monad (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) (lambda expander [branch] - (let [[pattern body] branch] - (_lux_case pattern - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) - (do Lux:Monad - [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) - expansions (map% Lux:Monad expander (as-pairs expansion))] - (;return (list:join expansions))) - - _ - (;return (list branch)))))) + (let [[pattern body] branch] + (_lux_case pattern + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) + (do Lux/Monad + [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) + expansions (map% Lux/Monad expander (as-pairs expansion))] + (;return (list:join expansions))) + + _ + (;return (list branch)))))) (as-pairs branches))] (;return (list (`' (_lux_case (~ value) (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) @@ -1621,7 +1617,7 @@ (defmacro #export (\ tokens) (case tokens (#Cons [body (#Cons [pattern #Nil])]) - (do Lux:Monad + (do Lux/Monad [pattern+ (macro-expand pattern)] (case pattern+ (#Cons [pattern' #Nil]) @@ -1641,8 +1637,8 @@ (fail "\\or can't have 0 patterns") _ - (do Lux:Monad - [patterns' (map% Lux:Monad macro-expand patterns)] + (do Lux/Monad + [patterns' (map% Lux/Monad macro-expand patterns)] (;return (list:join (map (lambda [pattern] (list pattern body)) (list:join patterns')))))) @@ -1650,13 +1646,13 @@ (fail "Wrong syntax for \\or"))) (do-template [ ] - [(def #export (int:+ ))] + [(def #export (i+ ))] [inc 1] [dec -1]) (defmacro #export (` tokens) - (do Lux:Monad + (do Lux/Monad [module-name get-module-name] (case tokens (\ (list template)) @@ -1678,7 +1674,7 @@ (def (macro-expand-1 token) (-> Syntax (Lux Syntax)) - (do Lux:Monad + (do Lux/Monad [token+ (macro-expand token)] (case token+ (\ (list token')) @@ -1688,14 +1684,14 @@ (fail "Macro expanded to more than 1 element.")))) (defmacro #export (sig tokens) - (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand tokens) - members (map% Lux:Monad + (do Lux/Monad + [tokens' (map% Lux/Monad macro-expand tokens) + members (map% Lux/Monad (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] (case token (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) - (do Lux:Monad + (do Lux/Monad [name' (normalize name)] (;return (: (, Ident Syntax) [name' type]))) @@ -1745,14 +1741,14 @@ (fail "Wrong syntax for defsig")))) (defmacro #export (struct tokens) - (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand tokens) - members (map% Lux:Monad + (do Lux/Monad + [tokens' (map% Lux/Monad macro-expand tokens) + members (map% Lux/Monad (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] (case token (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) - (do Lux:Monad + (do Lux/Monad [name' (normalize name)] (;return (: (, Syntax Syntax) [(tag$ name') value]))) @@ -1825,7 +1821,7 @@ (def (extract-defs defs) (-> (List Syntax) (Lux (List Text))) - (map% Lux:Monad + (map% Lux/Monad (: (-> Syntax (Lux Text)) (lambda [def] (case def @@ -1854,12 +1850,12 @@ (return (: (, Referrals (List Syntax)) [#All tokens'])) (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))])) - (do Lux:Monad + (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "except"])]) defs))])) - (do Lux:Monad + (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List Syntax)) [(#Except defs') tokens']))) @@ -1871,7 +1867,7 @@ (def (decorate-imports super-name tokens) (-> Text (List Syntax) (Lux (List Syntax))) - (map% Lux:Monad + (map% Lux/Monad (: (-> Syntax (Lux Syntax)) (lambda [token] (case token @@ -1887,8 +1883,8 @@ (def (parse-imports imports) (-> (List Syntax) (Lux (List Import))) - (do Lux:Monad - [referrals' (map% Lux:Monad + (do Lux/Monad + [referrals' (map% Lux/Monad (: (-> Syntax (Lux (List Import))) (lambda [token] (case token @@ -1896,7 +1892,7 @@ (;return (list [m-name #None #All])) (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) - (do Lux:Monad + (do Lux/Monad [alias+extra' (parse-alias extra) #let [[alias extra'] (: (, (Maybe Text) (List Syntax)) alias+extra')] @@ -1976,14 +1972,14 @@ (def (split-module-contexts module) (-> Text (List Text)) (#Cons [module (let [idx (last-index-of "/" module)] - (if (int:< idx 0) + (if (i< idx 0) #Nil (split-module-contexts (substring2 0 idx module))))])) (def (split-module module) (-> Text (List Text)) (let [idx (index-of "/" module)] - (if (int:< idx 0) + (if (i< idx 0) (#Cons [module #Nil]) (#Cons [(substring2 0 idx module) (split-module (substring1 (inc idx) module))])))) @@ -1996,7 +1992,7 @@ #None (#Cons [x xs']) - (if (int:= idx 0) + (if (i= idx 0) (#Some x) (@ (dec idx) xs') ))) @@ -2021,7 +2017,7 @@ (def (clean-module module) (-> Text (Lux Text)) - (do Lux:Monad + (do Lux/Monad [module-name get-module-name] (case (split-module module) (\ (list& "." parts)) @@ -2030,7 +2026,7 @@ parts (let [[ups parts'] (split-with (text:= "..") parts) num-ups (length ups)] - (if (int:= num-ups 0) + (if (i= num-ups 0) (return module) (case (@ num-ups (split-module-contexts module-name)) #None @@ -2062,23 +2058,23 @@ output)) (defmacro #export (import tokens) - (do Lux:Monad + (do Lux/Monad [imports (parse-imports tokens) - imports (map% Lux:Monad + imports (map% Lux/Monad (: (-> Import (Lux Import)) (lambda [import] (case import [m-name m-alias m-referrals] - (do Lux:Monad + (do Lux/Monad [m-name (clean-module m-name)] (;return (: Import [m-name m-alias m-referrals])))))) imports) - unknowns' (map% Lux:Monad + unknowns' (map% Lux/Monad (: (-> Import (Lux (List Text))) (lambda [import] (case import [m-name _ _] - (do Lux:Monad + (do Lux/Monad [? (module-exists? m-name)] (;return (if ? (list) @@ -2087,24 +2083,24 @@ #let [unknowns (list:join unknowns')]] (case unknowns #Nil - (do Lux:Monad - [output' (map% Lux:Monad + (do Lux/Monad + [output' (map% Lux/Monad (: (-> Import (Lux (List Syntax))) (lambda [import] (case import [m-name m-alias m-referrals] - (do Lux:Monad + (do Lux/Monad [defs (case m-referrals #All (exported-defs m-name) (#Only +defs) - (do Lux:Monad + (do Lux/Monad [*defs (exported-defs m-name)] (;return (filter (is-member? +defs) *defs))) (#Except -defs) - (do Lux:Monad + (do Lux/Monad [*defs (exported-defs m-name)] (;return (filter (. not (is-member? -defs)) *defs))) @@ -2270,7 +2266,7 @@ (defmacro #export (? tokens) (case tokens (\ (list maybe else)) - (do Lux:Monad + (do Lux/Monad [g!value (gensym "")] (return (list (` (case (~ maybe) (#;Some (~ g!value)) @@ -2292,7 +2288,7 @@ body)) (#AppT [F A]) - (do Maybe:Monad + (do Maybe/Monad [type-fn* (apply-type F A)] (apply-type type-fn* param)) @@ -2408,7 +2404,7 @@ ## {#source source #modules modules ## #envs envs #types types #host host ## #seed seed #seen-sources seen-sources #eval? eval?} state] -## (do Maybe:Monad +## (do Maybe/Monad ## [module (get v-prefix modules) ## #let [{#defs defs #module-aliases _ #imports _} module] ## def (get v-name defs) @@ -2421,7 +2417,7 @@ (def (find-var-type name) (-> Ident (Lux Type)) - (do Lux:Monad + (do Lux/Monad [name' (normalize name)] (lambda [state] (case (find-in-env name state) @@ -2444,7 +2440,7 @@ (\ (list struct body)) (case struct (#Meta [_ (#SymbolS name)]) - (do Lux:Monad + (do Lux/Monad [struct-type (find-var-type name)] (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) @@ -2491,7 +2487,7 @@ (f x y)))) (defmacro #export (cond tokens) - (if (int:= 0 (int:% (length tokens) 2)) + (if (i= 0 (i% (length tokens) 2)) (fail "cond requires an even number of arguments.") (case (reverse tokens) (\ (list& else branches')) @@ -2510,13 +2506,13 @@ (\ (list (#Meta [_ (#TagS slot')]) record)) (case record (#Meta [_ (#SymbolS name)]) - (do Lux:Monad + (do Lux/Monad [type (find-var-type name) g!blank (gensym "") g!output (gensym "")] (case (resolve-struct-type type) (#Some (#RecordT slots)) - (do Lux:Monad + (do Lux/Monad [slot (normalize slot')] (let [[s-prefix s-name] (: Ident slot) pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) @@ -2534,7 +2530,7 @@ (fail "get@ can only use records."))) _ - (do Lux:Monad + (do Lux/Monad [_record (gensym "")] (return (list (` (let [(~ _record) (~ record)] (get@ (~ (tag$ slot')) (~ _record)))))))) @@ -2545,7 +2541,7 @@ (defmacro #export (open tokens) (case tokens (\ (list (#Meta [_ (#SymbolS struct-name)]))) - (do Lux:Monad + (do Lux/Monad [struct-type (find-var-type struct-name)] (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) @@ -2579,8 +2575,8 @@ (defmacro #export (:: tokens) (case tokens (\ (list& start parts)) - (do Lux:Monad - [output (foldL% Lux:Monad + (do Lux/Monad + [output (foldL% Lux/Monad (: (-> Syntax Syntax (Lux Syntax)) (lambda [so-far part] (case part @@ -2604,16 +2600,16 @@ (\ (list (#Meta [_ (#TagS slot')]) value record)) (case record (#Meta [_ (#SymbolS name)]) - (do Lux:Monad + (do Lux/Monad [type (find-var-type name)] (case (resolve-struct-type type) (#Some (#RecordT slots)) - (do Lux:Monad - [pattern' (map% Lux:Monad + (do Lux/Monad + [pattern' (map% Lux/Monad (: (-> (, Text Type) (Lux (, Text Syntax))) (lambda [slot] (let [[r-slot-name r-type] slot] - (do Lux:Monad + (do Lux/Monad [g!slot (gensym "")] (return [r-slot-name g!slot]))))) slots) @@ -2639,7 +2635,7 @@ (fail "set@ can only use records."))) _ - (do Lux:Monad + (do Lux/Monad [_record (gensym "")] (return (list (` (let [(~ _record) (~ record)] (set@ (~ (tag$ slot')) (~ value) (~ _record)))))))) @@ -2652,16 +2648,16 @@ (\ (list (#Meta [_ (#TagS slot')]) fun record)) (case record (#Meta [_ (#SymbolS name)]) - (do Lux:Monad + (do Lux/Monad [type (find-var-type name)] (case (resolve-struct-type type) (#Some (#RecordT slots)) - (do Lux:Monad - [pattern' (map% Lux:Monad + (do Lux/Monad + [pattern' (map% Lux/Monad (: (-> (, Text Type) (Lux (, Text Syntax))) (lambda [slot] (let [[r-slot-name r-type] slot] - (do Lux:Monad + (do Lux/Monad [g!slot (gensym "")] (return [r-slot-name g!slot]))))) slots) @@ -2687,7 +2683,7 @@ (fail "update@ can only use records."))) _ - (do Lux:Monad + (do Lux/Monad [_record (gensym "")] (return (list (` (let [(~ _record) (~ record)] (update@ (~ (tag$ slot')) (~ fun) (~ _record)))))))) @@ -2695,6 +2691,33 @@ _ (fail "Wrong syntax for update@"))) +(defmacro #export (\template tokens) + (case tokens + (\ (list (#Meta [_ (#TupleS data)]) + (#Meta [_ (#TupleS bindings)]) + (#Meta [_ (#TupleS templates)]))) + (case (: (Maybe (List Syntax)) + (do Maybe/Monad + [bindings' (map% Maybe/Monad get-ident bindings) + data' (map% Maybe/Monad tuple->list data)] + (let [apply (: (-> RepEnv (List Syntax)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + ;return)))) + (#Some output) + (return output) + + #None + (fail "Wrong syntax for \\template")) + + _ + (fail "Wrong syntax for \\template"))) + +(def #export complement + (All [a] (-> (-> a Bool) (-> a Bool))) + (. not)) + ## (defmacro #export (loop tokens) ## (case tokens ## (\ (list bindings body)) @@ -2702,14 +2725,14 @@ ## vars (map first pairs) ## inits (map second pairs)] ## (if (every? symbol? inits) -## (do Lux:Monad -## [inits' (map% Maybe:Monad get-ident inits) -## init-types (map% Maybe:Monad find-var-type inits')] +## (do Lux/Monad +## [inits' (map% Maybe/Monad get-ident inits) +## init-types (map% Maybe/Monad find-var-type inits')] ## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] ## (~ body)) ## (~@ inits)))))) -## (do Lux:Monad -## [aliases (map% Maybe:Monad (lambda [_] (gensym "")) inits)] +## (do Lux/Monad +## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)] ## (return (list (` (let [(~@ (interleave aliases inits))] ## (loop [(~@ (interleave vars aliases))] ## (~ body))))))))) diff --git a/input/lux/codata/stream.lux b/input/lux/codata/stream.lux index 1bfd19292..1d6dd1b50 100644 --- a/input/lux/codata/stream.lux +++ b/input/lux/codata/stream.lux @@ -7,57 +7,127 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux (control (lazy #as L #refer #all)))) + (lux (control (lazy #as L #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all) + (comonad #as CM #refer #all)) + (meta lux + macro + syntax) + (data (list #as l #refer (#only list list& List/Monad))))) -## Types +## [Types] (deftype #export (Stream a) (Lazy (, a (Stream a)))) -## Functions +## [Utils] +(def (cycle' x xs init full) + (All [a] + (-> a (List a) a (List a) (Stream a))) + (case xs + #;Nil (cycle' init full init full) + (#;Cons [y xs']) (... [x (cycle' y xs' init full)]))) + +## [Functions] (def #export (iterate f x) (All [a] (-> (-> a a) a (Stream a))) (... [x (iterate f (f x))])) -## (def #export (take n xs) -## (All [a] -## (-> Int (Stream a) (List a))) -## (if (int:> n 0) -## (let [[x xs'] (! xs)] -## (list& x (take (dec n) xs'))) -## (list))) - -## (def #export (drop n xs) -## (All [a] -## (-> Int (Stream a) (Stream a))) -## (if (int:> n 0) -## (drop (dec n) (get@ 1 (! xs))) -## xs)) - -## Pattern-matching -## (defmacro #export (\stream tokens) -## (case tokens -## (\ (list& body patterns')) -## (do Lux:Monad -## [patterns (map% Lux:Monad M;macro-expand-1 patterns') -## g!s (M;gensym "s") -## #let [patterns+ (do List:Monad -## [pattern (reverse patterns)] -## (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))]] -## (wrap (list g!s -## (` (;let [(~@ patterns+)] -## (~ body)))))) - -## _ -## "Wrong syntax for \stream")) - -## (defsyntax #export (\stream body [patterns' (+$ id$)]) -## (do Lux:Monad -## [patterns (map% Lux:Monad M;macro-expand-1 patterns') -## g!s (M;gensym "s") -## #let [patterns+ (do List:Monad -## [pattern (reverse patterns)] -## (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))]] -## (wrap (list g!s -## (` (;let [(~@ patterns+)] -## (~ body))))))) +(def #export (repeat x) + (All [a] + (-> a (Stream a))) + (... [x (repeat x)])) + +(def #export (cycle xs) + (All [a] + (-> (List a) (Maybe (Stream a)))) + (case xs + #;Nil #;None + (#;Cons [x xs']) (#;Some (cycle' x xs' x xs')))) + +(do-template [ ] + [(def #export ( s) + (All [a] (-> (Stream a) )) + (let [[h t] (! s)] + ))] + + [head a h] + [tail (Stream a) t]) + +(def #export (@ idx s) + (All [a] (-> Int (Stream a) a)) + (let [[h t] (! s)] + (if (i> idx 0) + (@ (dec idx) t) + h))) + +(do-template [ ] + [(def #export ( det xs) + (All [a] + (-> (Stream a) (List a))) + (let [[x xs'] (! xs)] + (if + (list& x ( xs')) + (list)))) + + (def #export ( det xs) + (All [a] + (-> (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if + ( xs') + xs))) + + (def #export ( det xs) + (All [a] + (-> (Stream a) (, (List a) (Stream a)))) + (let [[x xs'] (! xs)] + (if + (let [[tail next] ( xs')] + [(#;Cons [x tail]) next]) + [(list) xs])))] + + [take-while drop-while split-with (-> a Bool) (det x) det] + [take drop split Int (i> det 0) (dec det)] + ) + +(def #export (unfold step init) + (All [a b] + (-> (-> a (, a b)) a (Stream b))) + (let [[next x] (step init)] + (... [x (unfold step next)]))) + +(def #export (filter p xs) + (All [a] (-> (-> a Bool) (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if (p x) + (... [x (filter p xs')]) + (filter p xs')))) + +(def #export (partition p xs) + (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a)))) + [(filter p xs) (filter (complement p) xs)]) + +## [Structures] +(defstruct #export Stream/Functor (Functor Stream) + (def (F;map f fa) + (let [[h t] (! fa)] + (... [(f h) (F;map f t)])))) + +(defstruct #export Stream/CoMonad (CoMonad Stream) + (def CM;_functor Stream/Functor) + (def CM;unwrap head) + (def (CM;split wa) + (:: Stream/Functor (F;map repeat wa)))) + +## [Pattern-matching] +(defsyntax #export (\stream body [patterns' (+^ id^)]) + (do Lux/Monad + [patterns (map% Lux/Monad macro-expand-1 patterns') + g!s (gensym "s") + #let [patterns+ (: (List Syntax) + (do List/Monad + [pattern (l;reverse patterns)] + (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] + (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) diff --git a/input/lux/control/functor.lux b/input/lux/control/functor.lux index 3362dd21a..6a9dcfff8 100644 --- a/input/lux/control/functor.lux +++ b/input/lux/control/functor.lux @@ -6,30 +6,10 @@ ## the terms of this license. ## You must not remove this notice, or any other, from this software. -(;import lux - (lux/data state)) +(;import lux) ## Signatures (defsig #export (Functor f) (: (All [a b] (-> (-> a b) (f a) (f b))) map)) - -## Structures -(defstruct #export Maybe:Functor (Functor Maybe) - (def (map f ma) - (case ma - #;None #;None - (#;Some a) (#;Some (f a))))) - -(defstruct #export List:Functor (Functor List) - (def (map f ma) - (case ma - #;Nil #;Nil - (#;Cons [a ma']) (#;Cons [(f a) (map f ma')])))) - -(defstruct #export State:Functor (Functor State) - (def (map f ma) - (lambda [state] - (let [[state' a] (ma state)] - [state' (f a)])))) diff --git a/input/lux/control/lazy.lux b/input/lux/control/lazy.lux index 83f094592..fca63179e 100644 --- a/input/lux/control/lazy.lux +++ b/input/lux/control/lazy.lux @@ -34,12 +34,12 @@ (thunk id)) ## Structs -(defstruct #export Lazy:Functor (Functor Lazy) +(defstruct #export Lazy/Functor (Functor Lazy) (def (F;map f ma) (... (f (! ma))))) -(defstruct #export Lazy:Monad (Monad Lazy) - (def M;_functor Lazy:Functor) +(defstruct #export Lazy/Monad (Monad Lazy) + (def M;_functor Lazy/Functor) (def (M;wrap a) (... a)) diff --git a/input/lux/control/monad.lux b/input/lux/control/monad.lux index 2ca541574..b5552f987 100644 --- a/input/lux/control/monad.lux +++ b/input/lux/control/monad.lux @@ -7,13 +7,38 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/data list - state) (.. (functor #as F) (monoid #as M)) lux/meta/macro) -## Signatures +## [Utils] +(def (foldL f init xs) + (All [a b] + (-> (-> a b a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + +(def (reverse xs) + (All [a] + (-> (List a) (List a))) + (foldL (lambda [tail head] (#;Cons [head tail])) + #;Nil + xs)) + +(def (as-pairs xs) + (All [a] (-> (List a) (List (, a a)))) + (case xs + (#;Cons [x1 (#;Cons [x2 xs'])]) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +## [Signatures] (defsig #export (Monad m) (: (F;Functor m) _functor) @@ -24,10 +49,11 @@ (-> (m (m a)) (m a))) join)) -## Syntax +## [Syntax] (defmacro #export (do tokens state) (case tokens - (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) (lambda [body' binding] (let [[var value] binding] @@ -43,49 +69,15 @@ )))) body (reverse (as-pairs bindings)))] - (#;Right [state (list (` (;case (~ monad) - {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} - (~ body'))))])) + (#;Right [state (#;Cons [(` (;case (~ monad) + {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} + (~ body'))) + #;Nil])])) _ (#;Left "Wrong syntax for do"))) -## Structures -(defstruct #export Maybe:Monad (Monad Maybe) - (def _functor F;Maybe:Functor) - - (def (wrap x) - (#;Some x)) - - (def (join mma) - (case mma - #;None #;None - (#;Some xs) xs))) - -(defstruct #export List:Monad (Monad List) - (def _functor F;List:Functor) - - (def (wrap x) - (#;Cons [x #;Nil])) - - (def (join xss) - (using M;List:Monoid - (foldL M;++ M;unit xss)))) - -(defstruct #export State:Monad (All [s] - (Monad (State s))) - (def _functor F;State:Functor) - - (def (wrap x) - (lambda [state] - [state x])) - - (def (join mma) - (lambda [state] - (let [[state' ma] (mma state)] - (ma state'))))) - -## Functions +## [Functions] (def #export (bind m f ma) (All [m a b] (-> (Monad m) (-> a (m b)) (m a) (m b))) diff --git a/input/lux/control/monoid.lux b/input/lux/control/monoid.lux index cfb282c52..d32baabc5 100644 --- a/input/lux/control/monoid.lux +++ b/input/lux/control/monoid.lux @@ -6,9 +6,7 @@ ## the terms of this license. ## You must not remove this notice, or any other, from this software. -(;import lux - (lux/data ord - (bounded #as B))) +(;import lux) ## Signatures (defsig #export (Monoid a) @@ -24,34 +22,3 @@ (struct (def unit unit) (def ++ ++))) - -## Structures -(defstruct #export Maybe:Monoid (Monoid Maybe) - (def unit #;None) - (def (++ xs ys) - (case xs - #;None ys - (#;Some x) (#;Some x)))) - -(defstruct #export List:Monoid (All [a] - (Monoid (List a))) - (def unit #;Nil) - (def (++ xs ys) - (case xs - #;Nil ys - (#;Cons [x xs']) (#;Cons [x (++ xs' ys)])))) - -(do-template [ <++>] - [(defstruct #export (Monoid ) - (def unit ) - (def ++ <++>))] - - [ IntAdd:Monoid Int 0 int:+] - [ IntMul:Monoid Int 1 int:*] - [RealAdd:Monoid Real 0.0 real:+] - [RealMul:Monoid Real 1.0 real:*] - [ IntMax:Monoid Int (:: B;Int:Bounded B;bottom) (max Int:Ord)] - [ IntMin:Monoid Int (:: B;Int:Bounded B;top) (min Int:Ord)] - [RealMax:Monoid Real (:: B;Real:Bounded B;bottom) (max Real:Ord)] - [RealMin:Monoid Real (:: B;Real:Bounded B;top) (min Real:Ord)] - ) diff --git a/input/lux/data/bounded.lux b/input/lux/data/bounded.lux index 14f4d2e86..458fbc0df 100644 --- a/input/lux/data/bounded.lux +++ b/input/lux/data/bounded.lux @@ -22,5 +22,5 @@ (def top ) (def bottom ))] - [Int:Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] - [Real:Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) + [ Int/Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] + [Real/Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) diff --git a/input/lux/data/dict.lux b/input/lux/data/dict.lux index 8bd6635fd..63a66d49b 100644 --- a/input/lux/data/dict.lux +++ b/input/lux/data/dict.lux @@ -69,7 +69,7 @@ (#;Cons [[k' v'] (pl-remove eq k kvs')])))) ## Structs -(defstruct #export PList:Dict (Dict PList) +(defstruct #export PList/Dict (Dict PList) (def (get k plist) (let [(#PList [eq kvs]) plist] (pl-get eq k kvs))) diff --git a/input/lux/data/either.lux b/input/lux/data/either.lux new file mode 100644 index 000000000..7166688b5 --- /dev/null +++ b/input/lux/data/either.lux @@ -0,0 +1,46 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data (list #refer (#except partition)))) + +## [Types] +## (deftype (Either l r) +## (| (#;Left l) +## (#;Right r))) + +## [Functions] +(def #export (either f g e) + (All [a b c] (-> (-> a c) (-> b c) (Either a b) c)) + (case e + (#;Left x) (f x) + (#;Right x) (g x))) + +(do-template [ ] + [(def #export ( es) + (All [a b] (-> (List (Either a b)) (List ))) + (case es + #;Nil #;Nil + (#;Cons [( x) es']) (#;Cons [x ( es')]) + (#;Cons [_ es']) ( es')))] + + [lefts a #;Left] + [rights b #;Right] + ) + +(def #export (partition es) + (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) + (foldL (: (All [a b] + (-> (, (List a) (List b)) (Either a b) (, (List a) (List b)))) + (lambda [tails e] + (let [[ltail rtail] tails] + (case e + (#;Left x) [(#;Cons [x ltail]) rtail] + (#;Right x) [ltail (#;Cons [x rtail])])))) + [(list) (list)] + (reverse es))) diff --git a/input/lux/data/eq.lux b/input/lux/data/eq.lux index 948f8e2ab..191e6a885 100644 --- a/input/lux/data/eq.lux +++ b/input/lux/data/eq.lux @@ -14,7 +14,7 @@ =)) ## Structures -(defstruct #export Bool:Eq (Eq Bool) +(defstruct #export Bool/Eq (Eq Bool) (def (= x y) (case (: (, Bool Bool) [x y]) (\or [true true] [false false]) @@ -22,14 +22,3 @@ _ false))) - -(defstruct #export Int:Eq (Eq Int) - (def = int:=)) - -(defstruct #export Real:Eq (Eq Real) - (def = real:=)) - -(defstruct #export Text:Eq (Eq Text) - (def (= x y) - (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] - x [y]))) diff --git a/input/lux/data/error.lux b/input/lux/data/error.lux new file mode 100644 index 000000000..cb5c309a6 --- /dev/null +++ b/input/lux/data/error.lux @@ -0,0 +1,34 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Error a) + (| (#Fail Text) + (#Ok a))) + +## [Structures] +(defstruct #export Error/Functor (Functor Error) + (def (F;map f ma) + (case ma + (#Fail msg) (#Fail msg) + (#Ok datum) (#Ok (f datum))))) + +(defstruct #export Error/Monad (Monad Error) + (def M;_functor Error/Functor) + + (def (M;wrap a) + (#Ok a)) + + (def (M;join mma) + (case mma + (#Fail msg) (#Fail msg) + (#Ok ma) ma))) diff --git a/input/lux/data/id.lux b/input/lux/data/id.lux new file mode 100644 index 000000000..0e3bdbee6 --- /dev/null +++ b/input/lux/data/id.lux @@ -0,0 +1,28 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Id a) + (| (#Id a))) + +## [Structures] +(defstruct #export Id/Functor (Functor Id) + (def (F;map f fa) + (let [(#Id a) fa] + (#Id (f a))))) + +(defstruct #export Id/Monad (Monad Id) + (def M;_functor Id/Functor) + (def (M;wrap a) (#Id a)) + (def (M;join mma) + (let [(#Id ma) mma] + ma))) diff --git a/input/lux/data/io.lux b/input/lux/data/io.lux index ab74daefd..c08023df5 100644 --- a/input/lux/data/io.lux +++ b/input/lux/data/io.lux @@ -27,12 +27,12 @@ (#;Left "Wrong syntax for io"))) ## Structures -(defstruct #export IO:Functor (F;Functor IO) +(defstruct #export IO/Functor (F;Functor IO) (def (F;map f ma) (io (f (ma []))))) -(defstruct #export IO:Monad (M;Monad IO) - (def M;_functor IO:Functor) +(defstruct #export IO/Monad (M;Monad IO) + (def M;_functor IO/Functor) (def (M;wrap x) (io x)) diff --git a/input/lux/data/list.lux b/input/lux/data/list.lux index edbdb6160..450dee275 100644 --- a/input/lux/data/list.lux +++ b/input/lux/data/list.lux @@ -6,7 +6,10 @@ ## the terms of this license. ## You must not remove this notice, or any other, from this software. -(;import (lux #refer (#except reverse as-pairs)) +(;import lux + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all)) lux/meta/macro) ## Types @@ -54,6 +57,10 @@ (#;Cons [x (filter p xs')]) (filter p xs')))) +(def #export (partition p xs) + (All [a] (-> (-> a Bool) (List a) (, (List a) (List a)))) + [(filter p xs) (filter (complement p) xs)]) + (def #export (as-pairs xs) (All [a] (-> (List a) (List (, a a)))) (case xs @@ -67,7 +74,7 @@ [(def #export ( n xs) (All [a] (-> Int (List a) (List a))) - (if (int:> n 0) + (if (i> n 0) (case xs #;Nil #;Nil @@ -97,16 +104,16 @@ [drop-while (drop-while p xs') xs] ) -(def #export (split-at n xs) +(def #export (split n xs) (All [a] (-> Int (List a) (, (List a) (List a)))) - (if (int:> n 0) + (if (i> n 0) (case xs #;Nil [#;Nil #;Nil] (#;Cons [x xs']) - (let [[tail rest] (split-at (dec n) xs')] + (let [[tail rest] (split (dec n) xs')] [(#;Cons [x tail]) rest])) [#;Nil xs])) @@ -131,7 +138,7 @@ (def #export (repeat n x) (All [a] (-> Int a (List a))) - (if (int:> n 0) + (if (i> n 0) (#;Cons [x (repeat (dec n) x)]) #;Nil)) @@ -175,7 +182,7 @@ (def #export (size list) (-> List Int) - (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) + (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) (do-template [ ] [(def #export ( p xs) @@ -194,7 +201,7 @@ #;None (#;Cons [x xs']) - (if (int:= 0 i) + (if (i= 0 i) (#;Some x) (@ (dec i) xs')))) @@ -216,3 +223,28 @@ _ (#;Left "Wrong syntax for list&"))) + +## Structures +(defstruct #export List/Monoid (All [a] + (Monoid (List a))) + (def m;unit #;Nil) + (def (m;++ xs ys) + (case xs + #;Nil ys + (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)])))) + +(defstruct #export List/Functor (Functor List) + (def (F;map f ma) + (case ma + #;Nil #;Nil + (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')])))) + +(defstruct #export List/Monad (Monad List) + (def M;_functor List/Functor) + + (def (M;wrap a) + (#;Cons [a #;Nil])) + + (def (M;join mma) + (using List/Monoid + (foldL m;++ m;unit mma)))) diff --git a/input/lux/data/maybe.lux b/input/lux/data/maybe.lux new file mode 100644 index 000000000..faec53c2e --- /dev/null +++ b/input/lux/data/maybe.lux @@ -0,0 +1,42 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +## (deftype (Maybe a) +## (| #;None +## (#;Some a))) + +## [Structures] +(defstruct #export Maybe/Monoid (Monoid Maybe) + (def m;unit #;None) + (def (m;++ xs ys) + (case xs + #;None ys + (#;Some x) (#;Some x)))) + +(defstruct #export Maybe/Functor (Functor Maybe) + (def (F;map f ma) + (case ma + #;None #;None + (#;Some a) (#;Some (f a))))) + +(defstruct #export Maybe/Monad (Monad Maybe) + (def M;_functor Maybe/Functor) + + (def (M;wrap x) + (#;Some x)) + + (def (M;join mma) + (case mma + #;None #;None + (#;Some xs) xs))) diff --git a/input/lux/data/number.lux b/input/lux/data/number.lux index 7941daa4e..8203d2ecd 100644 --- a/input/lux/data/number.lux +++ b/input/lux/data/number.lux @@ -6,38 +6,52 @@ ## the terms of this license. ## You must not remove this notice, or any other, from this software. -(;import lux) +(;import lux + (lux/control (monoid #as m)) + (lux/data (eq #as E) + (ord #as O) + (bounded #as B))) ## Signatures (defsig #export (Number n) - (: (-> n n n) - +) + (do-template [] + [(: (-> n n n) + )] + [+] [-] [*] [/] [%]) + ## (: (-> n n n) + ## +) - (: (-> n n n) - -) + ## (: (-> n n n) + ## -) - (: (-> n n n) - *) + ## (: (-> n n n) + ## *) - (: (-> n n n) - /) + ## (: (-> n n n) + ## /) - (: (-> n n n) - %) + ## (: (-> n n n) + ## %) (: (-> Int n) from-int) - (: (-> n n) - negate) + (do-template [] + [(: (-> n n) + )] + [negate] [signum] [abs]) + ## (: (-> n n) + ## negate) - (: (-> n n) - sign) + ## (: (-> n n) + ## signum) - (: (-> n n) - abs)) + ## (: (-> n n) + ## abs) + ) -## Structures +## [Structures] +## Number (do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] [(defstruct #export (Number ) (def + <+>) @@ -53,12 +67,42 @@ (if (<<> x <0>) (<*> <-1> x) x)) - (def (sign x) + (def (signum x) (cond (<=> x <0>) <0> (<<> x <0>) <-1> ## else <1>)) )] - [Int:Number Int int:+ int:- int:* int:/ int:% int:= int:< id 0 1 -1] - [Real:Number Real real:+ real:- real:* real:/ real:% real:= real:< _jvm_l2d 0.0 1.0 -1.0]) + [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1] + [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0]) + +## Eq +(defstruct #export Int/Eq (E;Eq Int) + (def E;= i=)) + +(defstruct #export Real/Eq (E;Eq Real) + (def E;= r=)) + +## Ord +(def #export Int/Ord (O;Ord Int) + (O;ord$ Int/Eq i< i>)) + +(def #export Real/Ord (O;Ord Real) + (O;ord$ Real/Eq r< r>)) + +## Monoid +(do-template [ <++>] + [(defstruct #export (m;Monoid ) + (def m;unit ) + (def m;++ <++>))] + + [ IntAdd/Monoid Int 0 i+] + [ IntMul/Monoid Int 1 i*] + [RealAdd/Monoid Real 0.0 r+] + [RealMul/Monoid Real 1.0 r*] + [ IntMax/Monoid Int (:: B;Int/Bounded B;bottom) (O;max Int/Ord)] + [ IntMin/Monoid Int (:: B;Int/Bounded B;top) (O;min Int/Ord)] + [RealMax/Monoid Real (:: B;Real/Bounded B;bottom) (O;max Real/Ord)] + [RealMin/Monoid Real (:: B;Real/Bounded B;top) (O;min Real/Ord)] + ) diff --git a/input/lux/data/ord.lux b/input/lux/data/ord.lux index 573106830..60a6cc0a8 100644 --- a/input/lux/data/ord.lux +++ b/input/lux/data/ord.lux @@ -27,15 +27,15 @@ (All [a] (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) (struct - (def _eq eq) - (def < <) - (def (<= x y) - (or (< x y) - (:: eq (E;= x y)))) - (def > >) - (def (>= x y) - (or (> x y) - (:: eq (E;= x y)))))) + (def _eq eq) + (def < <) + (def (<= x y) + (or (< x y) + (:: eq (E;= x y)))) + (def > >) + (def (>= x y) + (or (> x y) + (:: eq (E;= x y)))))) ## Functions (do-template [ ] @@ -47,10 +47,3 @@ [max ;;>] [min ;;<]) - -## Structures -(def #export Int:Ord (Ord Int) - (ord$ E;Int:Eq int:< int:>)) - -(def #export Real:Ord (Ord Real) - (ord$ E;Real:Eq real:< real:>)) diff --git a/input/lux/data/reader.lux b/input/lux/data/reader.lux new file mode 100644 index 000000000..c3bbc2830 --- /dev/null +++ b/input/lux/data/reader.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import (lux #refer (#except Reader)) + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Reader r a) + (-> r a)) + +## [Structures] +(defstruct #export Reader/Functor (All [r] + (Functor (Reader r))) + (def (F;map f fa) + (lambda [env] + (f (fa env))))) + +(defstruct #export Reader/Monad (All [r] + (Monad (Reader r))) + (def M;_functor Reader/Functor) + + (def (M;wrap x) + (lambda [env] x)) + + (def (M;join mma) + (lambda [env] + (mma env env)))) diff --git a/input/lux/data/show.lux b/input/lux/data/show.lux index 3748d481a..e081b9239 100644 --- a/input/lux/data/show.lux +++ b/input/lux/data/show.lux @@ -19,9 +19,9 @@ (def (show x) ))] - [Bool:Show Bool (_jvm_invokevirtual java.lang.Object toString [] x [])] - [Int:Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] - [Real:Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] - [Char:Show Char (let [char (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Bool/Show Bool (_jvm_invokevirtual java.lang.Object toString [] x [])] + [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Char/Show Char (let [char (_jvm_invokevirtual java.lang.Object toString [] x [])] ($ text:++ "#\"" char "\""))] - [Text:Show Text x]) + [Text/Show Text x]) diff --git a/input/lux/data/state.lux b/input/lux/data/state.lux index 386c7be1d..bc9858a29 100644 --- a/input/lux/data/state.lux +++ b/input/lux/data/state.lux @@ -6,8 +6,30 @@ ## the terms of this license. ## You must not remove this notice, or any other, from this software. -(;import lux) +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) -## Types +## [Types] (deftype #export (State s a) (-> s (, s a))) + +## [Structures] +(defstruct #export State/Functor (Functor State) + (def (F;map f ma) + (lambda [state] + (let [[state' a] (ma state)] + [state' (f a)])))) + +(defstruct #export State/Monad (All [s] + (Monad (State s))) + (def M;_functor State/Functor) + + (def (M;wrap x) + (lambda [state] + [state x])) + + (def (M;join mma) + (lambda [state] + (let [[state' ma] (mma state)] + (ma state'))))) diff --git a/input/lux/data/text.lux b/input/lux/data/text.lux index 1a8587f46..5f2203376 100644 --- a/input/lux/data/text.lux +++ b/input/lux/data/text.lux @@ -18,8 +18,8 @@ (def #export (@ idx x) (-> Int Text (Maybe Char)) - (if (and (int:< idx (size x)) - (int:>= idx 0)) + (if (and (i< idx (size x)) + (i>= idx 0)) (#;Some (_jvm_invokevirtual java.lang.String charAt [int] x [(_jvm_l2i idx)])) #;None)) @@ -46,9 +46,9 @@ (def #export (sub' from to x) (-> Int Int Text (Maybe Text)) - (if (and (int:< from to) - (int:>= from 0) - (int:<= to (size x))) + (if (and (i< from to) + (i>= from 0) + (i<= to (size x))) (_jvm_invokevirtual java.lang.String substring [int int] x [(_jvm_l2i from) (_jvm_l2i to)]) #;None)) @@ -59,8 +59,8 @@ (def #export (split at x) (-> Int Text (Maybe (, Text Text))) - (if (and (int:< at (size x)) - (int:>= at 0)) + (if (and (i< at (size x)) + (i>= at 0)) (let [pre (_jvm_invokevirtual java.lang.String substring [int int] x [(_jvm_l2i 0) (_jvm_l2i at)]) post (_jvm_invokevirtual java.lang.String substring [int] @@ -76,8 +76,7 @@ (do-template [ ] [(def #export ( pattern from x) (-> Text Int Text (Maybe Int)) - (if (and (int:< from (size x)) - (int:>= from 0)) + (if (and (i< from (size x)) (i>= from 0)) (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String int] x [pattern (_jvm_l2i from)])) -1 #;None @@ -108,32 +107,33 @@ (-> Text Text Bool) (case (last-index-of postfix x) (#;Some n) - (int:= (int:+ n (size postfix)) - (size x)) + (i= (i+ n (size postfix)) + (size x)) _ false)) -(defstruct #export Text:Eq (E;Eq Text) +## [Structures] +(defstruct #export Text/Eq (E;Eq Text) (def (E;= x y) (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] x [y]))) -(defstruct #export Text:Ord (O;Ord Text) - (def O;_eq Text:Eq) +(defstruct #export Text/Ord (O;Ord Text) + (def O;_eq Text/Eq) (def (O;< x y) - (int:< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) + (i< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) (def (O;<= x y) - (int:<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) + (i<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) (def (O;> x y) - (int:> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) + (i> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) (def (O;>= x y) - (int:>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0))) + (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0))) diff --git a/input/lux/data/writer.lux b/input/lux/data/writer.lux new file mode 100644 index 000000000..f71492e35 --- /dev/null +++ b/input/lux/data/writer.lux @@ -0,0 +1,34 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Writer l a) + (, l a)) + +## [Structures] +(defstruct #export Writer/Functor (All [l] + (Functor (Writer l))) + (def (F;map f fa) + (let [[log datum] fa] + [log (f datum)]))) + +(defstruct #export (Writer/Monad mon) (All [l] + (-> (Monoid l) (Monad (Writer l)))) + (def M;_functor Writer/Functor) + + (def (M;wrap x) + [(:: mon m;unit) x]) + + (def (M;join mma) + (let [[log1 [log2 a]] mma] + [(:: mon (m;++ log1 log2)) a]))) diff --git a/input/lux/host/java.lux b/input/lux/host/java.lux new file mode 100644 index 000000000..52391201d --- /dev/null +++ b/input/lux/host/java.lux @@ -0,0 +1,311 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (data list + (text #as text)) + (control (functor #as F) + (monad #as M #refer (#only do))) + (meta lux + macro + syntax))) + +## (open List/Functor) + +## [Utils/Parsers] +(def finally^ + (Parser Syntax) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "finally"]) + expr id^ + _ end^] + (M;wrap expr)))) + +(def catch^ + (Parser (, Text Ident Syntax)) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "catch"]) + ex-class local-symbol^ + ex symbol^ + expr id^ + _ end^] + (M;wrap [ex-class ex expr])))) + +(def method-decl^ + (Parser (, (List Text) Text (List Text) Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ local-symbol^)) + output local-symbol^ + _ end^] + (M;wrap [modifiers name inputs output])))) + +(def field-decl^ + (Parser (, (List Text) Text Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + class local-symbol^ + _ end^] + (M;wrap [modifiers name class])))) + +(def arg-decl^ + (Parser (, Text Text)) + (form^ (do Parser/Monad + [arg-name local-symbol^ + arg-class local-symbol^ + _ end^] + (M;wrap [arg-name arg-class])))) + +(def method-def^ + (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ arg-decl^)) + output local-symbol^ + body id^ + _ end^] + (M;wrap [modifiers name inputs output body])))) + +(def method-call^ + (Parser (, Text (List Text) (List Syntax))) + (form^ (do Parser/Monad + [method local-symbol^ + arity-classes (tuple^ (*^ local-symbol^)) + arity-args (tuple^ (*^ id^)) + _ end^ + _ (: (Parser (,)) + (if (i= (size arity-classes) + (size arity-args)) + (M;wrap []) + (lambda [_] #;None)))] + (M;wrap [method arity-classes arity-args]) + ))) + +## [Utils/Lux] +## (def (find-class-field field class) +## (-> Text Text (Lux Type)) +## ...) + +## (def (find-virtual-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + +## (def (find-static-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + + +## [Syntax] +(defsyntax #export (throw ex) + (emit (list (` (_jvm_throw (~ ex)))))) + +(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) + (emit (list (` (_jvm_try (~ body) + (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax) + (lambda [catch] + (let [[class ex body] catch] + (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches)) + (case finally + #;None + (list) + + (#;Some finally) + (list (` (_jvm_finally (~ finally)))))))))))) + +(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (text;++ (text;replace "/" "." current-module) + name)]] + (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + members))] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))] + (~@ members')))))))) + +(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [fields (*^ field-decl^)] + [methods (*^ method-def^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (text;++ (text;replace "/" "." current-module) + name) + fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" name])) + (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + fields)) + methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (symbol$ ["" name])) + [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs)))] + (~ (text$ output)) + [(~@ (:: List/Functor (F;map text$ modifiers)))] + (~ body)))))) + methods))]] + (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) + [(~@ (:: List/Functor (F;map text$ interfaces)))] + [(~@ fields')] + [(~@ methods')])))))) + +(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) + (emit (list (` (_jvm_new (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ arg-classes)))] + [(~@ args)]))))) + +(defsyntax #export (instance? [class local-symbol^] obj) + (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) + +(defsyntax #export (locking lock body) + (do Lux/Monad + [g!lock (gensym "") + g!body (gensym "")] + (emit (list (` (;let [(~ g!lock) (~ lock) + _ (_jvm_monitor-enter (~ g!lock)) + (~ g!body) (~ body) + _ (_jvm_monitor-exit (~ g!lock))] + (~ g!body))))) + )) + +(defsyntax #export (null? obj) + (emit (list (` (_jvm_null? (~ obj)))))) + +(defsyntax #export (program [args symbol^] body) + (emit (list (` (_jvm_program (~ (symbol$ args)) + (~ body)))))) + +## (defsyntax #export (.? [field local-symbol^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)))) + +## _ +## (fail "Can only get field from object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.? (~ field) (~ g!obj))))))))) + +## (defsyntax #export (.= [field local-symbol^] value obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value))) + +## _ +## (fail "Can only set field of object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.= (~ field) (~ value) (~ g!obj))))))))) + +## (defsyntax #export (.! [call method-call^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-virtual-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))] +## (~ obj) [(~@ m-args)]))))) + +## _ +## (fail "Can only call method on object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.! (~@ *tokens*))))))))) + +## (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) +## (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) + +## (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) +## (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) + +## (defsyntax #export (..! [call method-call^] [class local-symbol^]) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-static-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class)) +## [(~@ (:: List/Functor (F;map text$ m-ins)))] +## [(~@ m-args)])))) +## )) + +## (definterface Function [] +## (#public #abstract apply [java.lang.Object] java.lang.Object)) + +## (_jvm_interface "Function" [] +## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (defclass MyFunction [Function] +## (#public #static foo java.lang.Object) +## (#public [] void +## (_jvm_invokespecial java.lang.Object [] this [])) +## (#public apply [(arg java.lang.Object)] java.lang.Object +## "YOLO")) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## ( [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) diff --git a/input/lux/math.lux b/input/lux/math.lux new file mode 100644 index 000000000..2e29c5da7 --- /dev/null +++ b/input/lux/math.lux @@ -0,0 +1,60 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Constants] +(do-template [ ] + [(def #export + Real + (_jvm_getstatic java.lang.Math ))] + + [e E] + [pi PI] + ) + +## [Functions] +(do-template [ ] + [(def #export ( n) + (-> Real Real) + (_jvm_invokestatic java.lang.Math [double] [n]))] + + [cos cos] + [sin sin] + [tan tan] + + [acos acos] + [asin asin] + [atan atan] + + [cosh cosh] + [sinh sinh] + [tanh tanh] + + [ceil ceil] + [floor floor] + [round round] + + [exp exp] + [log log] + + [cbrt cbrt] + [sqrt sqrt] + + [->degrees toDegrees] + [->radians toRadians] + ) + +(do-template [ ] + [(def #export ( x y) + (-> Real Real Real) + (_jvm_invokestatic java.lang.Math [double double] [x y]))] + + [atan2 atan2] + [pow pow] + ) diff --git a/input/lux/meta/lux.lux b/input/lux/meta/lux.lux index bd4fab8b6..1fc739403 100644 --- a/input/lux/meta/lux.lux +++ b/input/lux/meta/lux.lux @@ -8,18 +8,25 @@ (;import lux (.. macro) - (lux/control (monoid #as m #refer (#only List:Monoid)) + (lux/control (monoid #as m) (functor #as F) (monad #as M #refer (#only do))) (lux/data list + maybe (show #as S))) -## Types +## [Types] ## (deftype (Lux a) ## (-> Compiler (Either Text (, Compiler a)))) -## Structures -(defstruct #export Lux:Functor (F;Functor Lux) +## [Utils] +(def (ident->text ident) + (-> Ident Text) + (let [[pre post] ident] + ($ text:++ pre ";" post))) + +## [Structures] +(defstruct #export Lux/Functor (F;Functor Lux) (def (F;map f fa) (lambda [state] (case (fa state) @@ -29,8 +36,8 @@ (#;Right [state' a]) (#;Right [state' (f a)]))))) -(defstruct #export Lux:Monad (M;Monad Lux) - (def M;_functor Lux:Functor) +(defstruct #export Lux/Monad (M;Monad Lux) + (def M;_functor Lux/Functor) (def (M;wrap x) (lambda [state] (#;Right [state x]))) @@ -68,7 +75,7 @@ (def (find-macro' modules current-module module name) (-> (List (, Text (Module Compiler))) Text Text Text (Maybe Macro)) - (do M;Maybe:Monad + (do Maybe/Monad [$module (get module modules) gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))] (case (: (, Bool (DefData' Macro)) gdef) @@ -85,7 +92,7 @@ (def #export (find-macro ident) (-> Ident (Lux (Maybe Macro))) - (do Lux:Monad + (do Lux/Monad [current-module get-module-name] (let [[module name] ident] (: (Lux (Maybe Macro)) @@ -96,50 +103,56 @@ (-> Ident (Lux Ident)) (case ident ["" name] - (do Lux:Monad + (do Lux/Monad [module-name get-module-name] (M;wrap (: Ident [module-name name]))) _ - (:: Lux:Monad (M;wrap ident)))) + (:: Lux/Monad (M;wrap ident)))) (def #export (macro-expand syntax) (-> Syntax (Lux (List Syntax))) (case syntax (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) - (do Lux:Monad + (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] (case ?macro (#;Some macro) - (do Lux:Monad + (do Lux/Monad [expansion (macro args) - expansion' (M;map% Lux:Monad macro-expand expansion)] - (M;wrap (:: M;List:Monad (M;join expansion')))) + expansion' (M;map% Lux/Monad macro-expand expansion)] + (M;wrap (:: List/Monad (M;join expansion')))) #;None - (do Lux:Monad - [parts' (M;map% Lux:Monad macro-expand (list& (symbol$ macro-name) args))] - (M;wrap (list (form$ (:: M;List:Monad (M;join parts')))))))) + (do Lux/Monad + [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] + (M;wrap (list (form$ (:: List/Monad (M;join parts')))))))) (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) - (do Lux:Monad + (do Lux/Monad [harg+ (macro-expand harg) - targs+ (M;map% Lux:Monad macro-expand targs)] - (M;wrap (list (form$ (list:++ harg+ (:: M;List:Monad (M;join (: (List (List Syntax)) targs+)))))))) + targs+ (M;map% Lux/Monad macro-expand targs)] + (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+)))))))) (#;Meta [_ (#;TupleS members)]) - (do Lux:Monad - [members' (M;map% Lux:Monad macro-expand members)] - (M;wrap (list (tuple$ (:: M;List:Monad (M;join members')))))) + (do Lux/Monad + [members' (M;map% Lux/Monad macro-expand members)] + (M;wrap (list (tuple$ (:: List/Monad (M;join members')))))) _ - (:: Lux:Monad (M;wrap (list syntax))))) + (:: Lux/Monad (M;wrap (list syntax))))) (def #export (gensym prefix state) (-> Text (Lux Syntax)) (#;Right [(update@ #;seed inc state) - (symbol$ ["__gensym__" (:: S;Int:Show (S;show (get@ #;seed state)))])])) + (symbol$ ["__gensym__" (:: S;Int/Show (S;show (get@ #;seed state)))])])) + +(def #export (emit datum) + (All [a] + (-> a (Lux a))) + (lambda [state] + (#;Right [state datum]))) (def #export (fail msg) (All [a] @@ -149,7 +162,7 @@ (def #export (macro-expand-1 token) (-> Syntax (Lux Syntax)) - (do Lux:Monad + (do Lux/Monad [token+ (macro-expand token)] (case token+ (\ (list token')) @@ -171,7 +184,7 @@ (-> Text (Lux (List Text))) (case (get module (get@ #;modules state)) (#;Some =module) - (using M;List:Monad + (using List/Monad (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) (List Text)) (lambda [gdef] @@ -183,3 +196,91 @@ #;None (#;Left ($ text:++ "Unknown module: " module)))) + +(def (show-envs envs) + (-> (List (Env Text (, LuxVar Type))) Text) + (|> envs + (F;map (lambda [env] + (case env + {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _} + ($ text:++ name ": " (|> locals + (F;map (: (All [a] (-> (, Text a) Text)) + (lambda [b] (let [[label _] b] label)))) + (:: List/Functor) + (interpose " ") + (foldL text:++ "")))))) + (:: List/Functor) + (interpose "\n") + (foldL text:++ ""))) + +(def (try-both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #;None (f x2) + (#;Some y) (#;Some y))) + +(def (find-in-env name state) + (-> Ident Compiler (Maybe Type)) + (let [vname' (ident->text name)] + (case state + {#;source source #;modules modules + #;envs envs #;types types #;host host + #;seed seed #;seen-sources seen-sources #;eval? eval?} + (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (lambda [env] + (case env + {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} + (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= vname' bname) + (#;Some type) + #;None))))) + locals + closure)))) + envs)))) + +(def (find-in-defs name state) + (-> Ident Compiler (Maybe Type)) + (let [[v-prefix v-name] name + {#;source source #;modules modules + #;envs envs #;types types #;host host + #;seed seed #;seen-sources seen-sources #;eval? eval?} state] + (case (get v-prefix modules) + #;None + #;None + + (#;Some {#;defs defs #;module-aliases _ #;imports _}) + (case (get v-name defs) + #;None + #;None + + (#;Some [_ def-data]) + (case def-data + #;TypeD (#;Some Type) + (#;ValueD type) (#;Some type) + (#;MacroD m) (#;Some Macro) + (#;AliasD name') (find-in-defs name' state)))))) + +(def #export (find-var-type name) + (-> Ident (Lux Type)) + (do Lux/Monad + [name' (normalize name)] + (: (Lux Type) + (lambda [state] + (case (find-in-env name state) + (#;Some struct-type) + (#;Right [state struct-type]) + + _ + (case (find-in-defs name' state) + (#;Some struct-type) + (#;Right [state struct-type]) + + _ + (let [{#;source source #;modules modules + #;envs envs #;types types #;host host + #;seed seed #;seen-sources seen-sources #;eval? eval?} state] + (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) + )) diff --git a/input/lux/meta/syntax.lux b/input/lux/meta/syntax.lux index cf08ff0eb..3c9a9ce2e 100644 --- a/input/lux/meta/syntax.lux +++ b/input/lux/meta/syntax.lux @@ -8,7 +8,7 @@ (;import lux (.. (macro #as m #refer #all) - lux) + (lux #as l #refer (#only Lux/Monad gensym))) (lux (control (functor #as F) (monad #as M #refer (#only do))) (data list))) @@ -19,12 +19,18 @@ (let [[x y] xy] x)) +(def (join-pairs pairs) + (All [a] (-> (List (, a a)) (List a))) + (case pairs + #;Nil #;Nil + (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) + ## Types (deftype #export (Parser a) (-> (List Syntax) (Maybe (, (List Syntax) a)))) ## Structures -(defstruct #export Parser:Functor (F;Functor Parser) +(defstruct #export Parser/Functor (F;Functor Parser) (def (F;map f ma) (lambda [tokens] (case (ma tokens) @@ -34,8 +40,8 @@ (#;Some [tokens' a]) (#;Some [tokens' (f a)]))))) -(defstruct #export Parser:Monad (M;Monad Parser) - (def M;_functor Parser:Functor) +(defstruct #export Parser/Monad (M;Monad Parser) + (def M;_functor Parser/Functor) (def (M;wrap x tokens) (#;Some [tokens x])) @@ -75,6 +81,20 @@ [ tag^ Ident #;TagS] ) +(do-template [ ] + [(def #export ( tokens) + (Parser Text) + (case tokens + (#;Cons [(#;Meta [_ ( ["" x])]) tokens']) + (#;Some [tokens' x]) + + _ + #;None))] + + [local-symbol^ #;SymbolS] + [ local-tag^ #;TagS] + ) + (def (bool:= x y) (-> Bool Bool Bool) (if x @@ -101,8 +121,8 @@ #;None))] [ bool?^ Bool #;BoolS bool:=] - [ int?^ Int #;IntS int:=] - [ real?^ Real #;RealS real:=] + [ int?^ Int #;IntS i=] + [ real?^ Real #;RealS r=] ## [ char?^ Char #;CharS char:=] [ text?^ Text #;TextS text:=] [symbol?^ Ident #;SymbolS ident:=] @@ -143,7 +163,7 @@ (-> (Parser a) (Parser (List a)))) (case (p tokens) #;None (#;Some [tokens (list)]) - (#;Some [tokens' x]) (run-parser (do Parser:Monad + (#;Some [tokens' x]) (run-parser (do Parser/Monad [xs (*^ p)] (M;wrap (list& x xs))) tokens'))) @@ -151,7 +171,7 @@ (def #export (+^ p) (All [a] (-> (Parser a) (Parser (List a)))) - (do Parser:Monad + (do Parser/Monad [x p xs (*^ p)] (M;wrap (list& x xs)))) @@ -159,7 +179,7 @@ (def #export (&^ p1 p2) (All [a b] (-> (Parser a) (Parser b) (Parser (, a b)))) - (do Parser:Monad + (do Parser/Monad [x1 p1 x2 p2] (M;wrap [x1 x2]))) @@ -169,7 +189,7 @@ (-> (Parser a) (Parser b) (Parser (Either b)))) (case (p1 tokens) (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) - #;None (run-parser (do Parser:Monad + #;None (run-parser (do Parser/Monad [x2 p2] (M;wrap (#;Right x2))) tokens))) @@ -192,46 +212,53 @@ ## Syntax (defmacro #export (defsyntax tokens) - (case tokens - (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) - body)) - (do Lux:Monad - [names+parsers (M;map% Lux:Monad - (: (-> Syntax (Lux (, Syntax Syntax))) - (lambda [arg] - (case arg - (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) - parser))])) - (M;wrap [(symbol$ var-name) parser]) - - _ - (fail "Syntax pattern expects 2-tuples.")))) - args) - g!tokens (gensym "tokens") - #let [names (:: F;List:Functor (F;map first names+parsers)) - error-msg (text$ (text:++ "Wrong syntax for " name)) - parsing (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (let [[exported? tokens] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens]))] + (case tokens + (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) + body)) + (do Lux/Monad + [names+parsers (M;map% Lux/Monad + (: (-> Syntax (Lux (, Syntax Syntax))) + (lambda [arg] + (case arg + (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) + parser))])) + (M;wrap [(symbol$ var-name) parser]) + + (\ (#;Meta [_ (#;SymbolS var-name)])) + (M;wrap [(symbol$ var-name) (` id^)]) + + _ + (l;fail "Syntax pattern expects 2-tuples or symbols.")))) + args) + g!tokens (gensym "tokens") + g!_ (gensym "_") + #let [names (:: List/Functor (F;map first names+parsers)) + error-msg (text$ (text:++ "Wrong syntax for " name)) + body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) (lambda [body name+parser] (let [[name parser] name+parser] (` (_lux_case ((~ parser) (~ g!tokens)) (#;Some [(~ g!tokens) (~ name)]) (~ body) - _ - #;None))))) - (: Syntax (` (#;Some [(~@ names)]))) + (~ g!_) + (l;fail (~ error-msg))))))) + body (reverse names+parsers)) - body' (: Syntax - (` (_lux_case (~ parsing) - (#;Some [#;Nil [(~@ names)]]) - (~ body) - - _ - (l;fail (~ (text$ (text:++ "Wrong syntax for " name))))))) - macro-def (: Syntax - (` (m/defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) - (~ body'))))]] - (M;wrap (list macro-def))) - - _ - (fail "Wrong syntax for defsyntax"))) + macro-def (: Syntax + (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) + (~ body'))))]] + (M;wrap (list& macro-def + (if exported? + (list (` (_lux_export (~ (symbol$ ["" name]))))) + (list))))) + + _ + (l;fail "Wrong syntax for defsyntax")))) diff --git a/input/program.lux b/input/program.lux index 6495854c1..19ee964e2 100644 --- a/input/program.lux +++ b/input/program.lux @@ -1,25 +1,35 @@ (;import lux - (lux (control monoid + (lux (codata (stream #as S)) + (control monoid functor monad lazy comonad) - (data eq - bounded - ord + (data bounded + ## cont + dict + (either #as e) + eq + error + id io list - state + maybe number + ord + (reader #as r) + show + state (text #as t) - dict - show) - (codata (stream #refer (#except iterate))) + writer) + (host java) (meta lux macro - syntax))) + syntax) + math + )) -(_jvm_program args +(program args (case args #;Nil (println "Hello, world!") diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 8c8be29d2..782ae4685 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -26,214 +26,128 @@ ["lux;Nil" _]]]]]]]]] (&/T catch+ ?finally-body))) -(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (|list))))] - (defn ^:private aba1 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] - ;; Standard special forms - [["lux;BoolS" ?value]] - (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - - [["lux;IntS" ?value]] - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - - [["lux;RealS" ?value]] - (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - - [["lux;CharS" ?value]] - (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - - [["lux;TextS" ?value]] - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - - [["lux;TupleS" ?elems]] - (&&lux/analyse-tuple analyse exo-type ?elems) - - [["lux;RecordS" ?elems]] - (&&lux/analyse-record analyse exo-type ?elems) - - [["lux;TagS" ?ident]] - (&&lux/analyse-variant analyse exo-type ?ident unit) - - [["lux;SymbolS" [_ "_jvm_null"]]] - (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) - - [_] - (fail "") - ))) - -(defn ^:private aba2 [analyse eval! compile-module exo-type token] +(defn ^:private aba7 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - [["lux;SymbolS" ?ident]] - (&&lux/analyse-symbol analyse exo-type ?ident) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]] - ["lux;Cons" [?value ?branches]]]]]] - (&&lux/analyse-case analyse exo-type ?value ?branches) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]]]] - (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Cons" [?value + ;; Arrays + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-def analyse ?name ?value) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Nil" _]]]]]]] - (&&lux/analyse-declare-macro analyse ?name) + (&&host/analyse-jvm-new-array analyse ?class ?length) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] - ["lux;Nil" _]]]]]]] - (&&lux/analyse-import analyse compile-module ?path) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] + ["lux;Cons" [?array + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] + ["lux;Cons" [?elem + ["lux;Nil" _]]]]]]]]]]] + (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] + ["lux;Cons" [?array + ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-check analyse eval! exo-type ?type ?value) + (&&host/analyse-jvm-aaload analyse ?array ?idx) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) + ;; Classes & interfaces + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] + ?methods]]]]]]]]]]]] + (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] - ["lux;Nil" _]]]]]]] - (&&lux/analyse-export analyse ?ident) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] + ?methods]]]]]]]] + (&&host/analyse-jvm-interface analyse ?name ?supers ?methods) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] + ;; Programs + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] + ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-alias analyse ?alias ?module) + (&&host/analyse-jvm-program analyse ?args ?body) [_] (fail ""))) -(defn ^:private aba3 [analyse eval! compile-module exo-type token] +(defn ^:private aba6 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - ;; Host special forms - ;; Integer arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-iadd analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-isub analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-imul analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-idiv analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-irem analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ieq analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ilt analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-igt analyse ?x ?y) - - ;; Long arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ladd analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lsub analyse ?x ?y) - - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lmul analyse ?x ?y) + ;; Primitive conversions + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-d2f analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ldiv analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-d2i analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lrem analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-d2l analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-leq analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-f2d analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-llt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-f2i analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lgt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-f2l analyse ?value) - [_] - (fail ""))) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2b analyse ?value) -(defn ^:private aba4 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] - ;; Float arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fadd analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2c analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fsub analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2d analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fmul analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2f analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fdiv analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2l analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-frem analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-i2s analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-feq analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-l2d analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-flt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-l2f analyse ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fgt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + (&&host/analyse-jvm-l2i analyse ?value) - ;; Double arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dadd analyse ?x ?y) + ;; Bitwise operators + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-iand analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dsub analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ior analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dmul analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-land analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ddiv analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lor analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-drem analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lxor analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-deq analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lshl analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dlt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lshr analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dgt analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lushr analyse ?x ?y) [_] - (fail ""))) + (aba7 analyse eval! compile-module exo-type token))) (defn ^:private aba5 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] @@ -242,6 +156,12 @@ ["lux;Cons" [?object ["lux;Nil" _]]]]]]] (&&host/analyse-jvm-null? analyse ?object) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_instanceof"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [?object + ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-instanceof analyse ?class ?object) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] @@ -336,130 +256,226 @@ (&&host/analyse-jvm-monitorexit analyse ?monitor) [_] - (fail ""))) + (aba6 analyse eval! compile-module exo-type token))) -(defn ^:private aba6 [analyse eval! compile-module exo-type token] +(defn ^:private aba4 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - ;; Primitive conversions - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-d2f analyse ?value) + ;; Float arithmetic + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fadd analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-d2i analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fsub analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-d2l analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fmul analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-f2d analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fdiv analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-f2i analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-frem analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-f2l analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-feq analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2b analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-flt analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2c analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-fgt analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2d analyse ?value) + ;; Double arithmetic + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dadd analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2f analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dsub analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2l analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dmul analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2s analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ddiv analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-l2d analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-drem analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-l2f analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-deq analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-l2i analyse ?value) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dlt analyse ?x ?y) - ;; Bitwise operators - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-iand analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-dgt analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ior analyse ?x ?y) + [_] + (aba5 analyse eval! compile-module exo-type token))) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-land analyse ?x ?y) +(defn ^:private aba3 [analyse eval! compile-module exo-type token] + (matchv ::M/objects [token] + ;; Host special forms + ;; Characters + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ceq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ceq analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lor analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_clt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-clt analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lxor analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_cgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-cgt analyse ?x ?y) + + ;; Integer arithmetic + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-iadd analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lshl analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-isub analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lshr analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-imul analyse ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lushr analyse ?x ?y) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-idiv analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-irem analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ieq analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ilt analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-igt analyse ?x ?y) + + ;; Long arithmetic + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ladd analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lsub analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lmul analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-ldiv analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lrem analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-leq analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-llt analyse ?x ?y) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + (&&host/analyse-jvm-lgt analyse ?x ?y) [_] - (fail ""))) + (aba4 analyse eval! compile-module exo-type token))) -(defn ^:private aba7 [analyse eval! compile-module exo-type token] +(defn ^:private aba2 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] - ;; Arrays - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] - ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-new-array analyse ?class ?length) + [["lux;SymbolS" ?ident]] + (&&lux/analyse-symbol analyse exo-type ?ident) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Cons" [?elem + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]] + ["lux;Cons" [?value ?branches]]]]]] + (&&lux/analyse-case analyse exo-type ?value ?branches) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]] + ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) + (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] + ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-aaload analyse ?array ?idx) + (&&lux/analyse-def analyse ?name ?value) - ;; Classes & interfaces - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] - ?methods]]]]]]]]]]]] - (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] + ["lux;Nil" _]]]]]]] + (&&lux/analyse-declare-macro analyse ?name) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] - ?methods]]]]]]]] - (&&host/analyse-jvm-interface analyse ?name ?supers ?methods) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] + ["lux;Nil" _]]]]]]] + (&&lux/analyse-import analyse compile-module ?path) - ;; Programs - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] - ["lux;Cons" [?body + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] + ["lux;Cons" [?type + ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-program analyse ?args ?body) + (&&lux/analyse-check analyse eval! exo-type ?type ?value) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]] + ["lux;Cons" [?type + ["lux;Cons" [?value + ["lux;Nil" _]]]]]]]]] + (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] + ["lux;Nil" _]]]]]]] + (&&lux/analyse-export analyse ?ident) + + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] + ["lux;Nil" _]]]]]]]]] + (&&lux/analyse-alias analyse ?alias ?module) [_] - (fail ""))) + (aba3 analyse eval! compile-module exo-type token))) + +(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (|list))))] + (defn ^:private aba1 [analyse eval! compile-module exo-type token] + (matchv ::M/objects [token] + ;; Standard special forms + [["lux;BoolS" ?value]] + (|do [_ (&type/check exo-type &type/Bool)] + (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) + + [["lux;IntS" ?value]] + (|do [_ (&type/check exo-type &type/Int)] + (return (&/|list (&/T (&/V "int" ?value) exo-type)))) + + [["lux;RealS" ?value]] + (|do [_ (&type/check exo-type &type/Real)] + (return (&/|list (&/T (&/V "real" ?value) exo-type)))) + + [["lux;CharS" ?value]] + (|do [_ (&type/check exo-type &type/Char)] + (return (&/|list (&/T (&/V "char" ?value) exo-type)))) + + [["lux;TextS" ?value]] + (|do [_ (&type/check exo-type &type/Text)] + (return (&/|list (&/T (&/V "text" ?value) exo-type)))) + + [["lux;TupleS" ?elems]] + (&&lux/analyse-tuple analyse exo-type ?elems) + + [["lux;RecordS" ?elems]] + (&&lux/analyse-record analyse exo-type ?elems) + + [["lux;TagS" ?ident]] + (&&lux/analyse-variant analyse exo-type ?ident unit) + + [["lux;SymbolS" [_ "_jvm_null"]]] + (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) + + [_] + (aba2 analyse eval! compile-module exo-type token) + ))) (defn ^:private add-loc [meta ^String msg] (if (.startsWith msg "@") @@ -477,55 +493,7 @@ (return* state* output) [["lux;Left" ""]] - (matchv ::M/objects [((aba2 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (matchv ::M/objects [((aba3 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (matchv ::M/objects [((aba4 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (matchv ::M/objects [((aba5 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (matchv ::M/objects [((aba6 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (matchv ::M/objects [((aba7 analyse eval! compile-module exo-type ?token) state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" ""]] - (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) - - [["lux;Left" msg]] - (fail* (add-loc meta msg))) - - [["lux;Left" msg]] - (fail* (add-loc meta msg))) - - [["lux;Left" msg]] - (fail* (add-loc meta msg))) - - [["lux;Left" msg]] - (fail* (add-loc meta msg))) - - [["lux;Left" msg]] - (fail* (add-loc meta msg))) - - [["lux;Left" msg]] - (fail* (add-loc meta msg))) + (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) [["lux;Left" msg]] (fail* (add-loc meta msg)) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 6dfa234bd..267bd1269 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -63,28 +63,31 @@ (return (&/T (&/V "TextTestAC" ?value) =kont))) [["lux;TupleS" ?members]] - (matchv ::M/objects [value-type] - [["lux;TupleT" ?member-types]] - (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Analyser 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 "[Analyser Error] Tuples require tuple-types: " (&type/show-type value-type)))) + (|do [value-type* (resolve-type value-type)] + (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) + (matchv ::M/objects [value-type*] + [["lux;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*)))))) [["lux;RecordS" ?slots]] (|do [value-type* (resolve-type value-type)] (matchv ::M/objects [value-type*] [["lux;RecordT" ?slot-types]] (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) - (fail (str "[Analyser error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) + (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) (|do [[=tests =kont] (&/fold (fn [kont* slot] (|let [[sn sv] slot] (matchv ::M/objects [sn] @@ -93,17 +96,17 @@ (if-let [=slot-type (&/|get =tag ?slot-types)] (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] (return (&/T (&/|put =tag =test =tests) =kont))) - (fail (str "[Pattern-Matching Error] Record-type lacks slot: " =tag)))) + (fail (str "[Pattern-matching Error] Record-type lacks slot: " =tag)))) [_] - (fail (str "[Pattern-Matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) + (fail (str "[Pattern-matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) (|do [=kont kont] (return (&/T (&/|table) =kont))) (&/|reverse ?slots))] (return (&/T (&/V "RecordTestAC" =tests) =kont)))) [_] - (fail "[Analyser Error] Record requires record-type."))) + (fail "[Pattern-matching Error] Record requires record-type."))) [["lux;TagS" ?ident]] (|do [=tag (&&/resolved-ident ?ident) @@ -182,7 +185,7 @@ (merge-total v (&/T t ?body))) ?values ?tests)] (return (&/V "TupleTotal" (&/T total? structs)))) - (fail "[Pattern-matching error] Inconsistent tuple-size.")) + (fail "[Pattern-matching Error] Inconsistent tuple-size.")) [["DefaultTotal" total?] ["RecordTestAC" ?tests]] (|do [structs (&/map% (fn [t] @@ -203,14 +206,14 @@ (if (.equals ^Object lslot rslot) (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] (return (&/T lslot sub-struct*))) - (fail "[Pattern-matching error] Record slots mismatch.")))) + (fail "[Pattern-matching Error] Record slots mismatch.")))) ?values (->> ?tests &/->seq (sort compare-kv) &/->list))] (return (&/V "RecordTotal" (&/T total? structs)))) - (fail "[Pattern-matching error] Inconsistent record-size.")) + (fail "[Pattern-matching Error] Inconsistent record-size.")) [["DefaultTotal" total?] ["VariantTestAC" [?tag ?test]]] (|do [sub-struct (merge-total (&/V "DefaultTotal" total?) @@ -245,15 +248,16 @@ [["TupleTotal" [?total ?structs]]] (if ?total (return true) - (matchv ::M/objects [value-type] - [["lux;TupleT" ?members]] - (|do [totals (&/map2% (fn [sub-struct ?member] - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) + (|do [value-type* (resolve-type value-type)] + (matchv ::M/objects [value-type*] + [["lux;TupleT" ?members]] + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) - [_] - (fail ""))) + [_] + (fail "[Pattern-maching Error] Tuple is not total.")))) [["RecordTotal" [?total ?structs]]] (if ?total @@ -270,7 +274,7 @@ (return (&/fold #(and %1 %2) true totals))) [_] - (fail "")))) + (fail "[Pattern-maching Error] Record is not total.")))) [["VariantTotal" [?total ?structs]]] (if ?total @@ -287,7 +291,7 @@ (return (&/fold #(and %1 %2) true totals))) [_] - (fail "")))) + (fail "[Pattern-maching Error] Variant is not total.")))) [["DefaultTotal" ?total]] (return ?total) @@ -304,4 +308,4 @@ ? (check-totality value-type struct)] (if ? (return patterns) - (fail "[Pattern-maching error] Pattern-matching is non-total.")))) + (fail "[Pattern-maching Error] Pattern-matching is non-total.")))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 3db4bd16d..918bcb8f1 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -54,6 +54,10 @@ analyse-jvm-ilt "jvm-ilt" "java.lang.Integer" "java.lang.Boolean" analyse-jvm-igt "jvm-igt" "java.lang.Integer" "java.lang.Boolean" + analyse-jvm-ceq "jvm-ceq" "java.lang.Character" "java.lang.Boolean" + analyse-jvm-clt "jvm-clt" "java.lang.Character" "java.lang.Boolean" + analyse-jvm-cgt "jvm-cgt" "java.lang.Character" "java.lang.Boolean" + analyse-jvm-ladd "jvm-ladd" "java.lang.Long" "java.lang.Long" analyse-jvm-lsub "jvm-lsub" "java.lang.Long" "java.lang.Long" analyse-jvm-lmul "jvm-lmul" "java.lang.Long" "java.lang.Long" @@ -93,21 +97,37 @@ (defn analyse-jvm-putstatic [analyse ?class ?field ?value] (|do [=type (&host/lookup-static-field ?class ?field) - =value (&&/analyse-1 analyse ?value)] + =value (&&/analyse-1 analyse =type ?value)] (return (&/|list (&/T (&/V "jvm-putstatic" (&/T ?class ?field =value)) =type))))) (defn analyse-jvm-putfield [analyse ?class ?field ?object ?value] (|do [=type (&host/lookup-static-field ?class ?field) =object (&&/analyse-1 analyse ?object) - =value (&&/analyse-1 analyse ?value)] + =value (&&/analyse-1 analyse =type ?value)] (return (&/|list (&/T (&/V "jvm-putfield" (&/T ?class ?field =object =value)) =type))))) (defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args] (|do [=classes (&/map% &host/extract-jvm-param ?classes) =return (&host/lookup-static-method ?class ?method =classes) - =args (&/flat-map% analyse ?args)] + :let [_ (matchv ::M/objects [=return] + [["lux;DataT" _return-class]] + (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] + =args (&/map2% (fn [_class _arg] + (&&/analyse-1 analyse (&/V "lux;DataT" _class) _arg)) + =classes + ?args)] (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T ?class ?method =classes =args)) =return))))) +(defn analyse-jvm-instanceof [analyse ?class ?object] + (|do [=object (analyse-1+ analyse ?object) + :let [[_obj _type] =object]] + (matchv ::M/objects [_type] + [["lux;DataT" _]] + (return (&/|list (&/T (&/V "jvm-instanceof" (&/T ?class ?object)) (&/V "lux;DataT" "java.lang.Boolean")))) + + [_] + (fail "[Analyser Error] Can only use instanceof with object types.")))) + (do-template [ ] (defn [analyse ?class ?method ?classes ?object ?args] (|do [=classes (&/map% &host/extract-jvm-param ?classes) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index d02599f10..75881c80a 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -248,11 +248,11 @@ [["lux;MacroD" macro]] (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) :let [_ (when (and ;; (= "lux/control/monad" ?module) - (= "do" ?name)) + (= "case" ?name)) (->> (&/|map &/show-ast macro-expansion) (&/|interpose "\n") (&/fold str "") - (prn ?module "do")))] + (prn ?module "case")))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) @@ -310,7 +310,9 @@ [["lux;VarT" ?id]] (|do [? (&type/bound? ?id)] (if ? - (|do [dtype (&type/deref ?id)] + (|do [dtype (&type/deref ?id) + ;; dtype* (&type/actual-type dtype) + ] (matchv ::M/objects [dtype] [["lux;ExT" _]] (return (&/T _expr exo-type)) @@ -341,7 +343,7 @@ (|do [module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? - (fail (str "[Analyser Error] Can't redefine " ?name)) + (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) (|do [=value (&/with-scope ?name (analyse-1+ analyse ?value)) =value-type (&&/expr-type =value)] diff --git a/src/lux/base.clj b/src/lux/base.clj index d88bb2ec1..e22e51473 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -158,7 +158,6 @@ )))) (defmacro |do [steps return] - (assert (not= 0 (count steps)) "The steps can't be empty!") (assert (= 0 (rem (count steps) 2)) "The number of steps must be even!") (reduce (fn [inner [label computation]] (case label @@ -330,6 +329,9 @@ map% |cons flat-map% |++) +(defn list-join [xss] + (fold |++ (V "lux;Nil" nil) xss)) + (defn |as-pairs [xs] (matchv ::M/objects [xs] [["lux;Cons" [x ["lux;Cons" [y xs*]]]]] @@ -669,6 +671,14 @@ [_ _] (fail "Lists don't match in size."))) +(defn map2 [f xs ys] + (matchv ::M/objects [xs ys] + [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|cons (f x y) (map2 f xs* ys*)) + + [_ _] + (V "lux;Nil" nil))) + (defn fold2 [f init xs ys] (matchv ::M/objects [xs ys] [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 04f4fb4c2..559c1179b 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -74,6 +74,16 @@ [["ann" [?value-ex ?type-ex]]] (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) + + ;; Characters + [["jvm-ceq" [?x ?y]]] + (&&host/compile-jvm-ceq compile-expression ?type ?x ?y) + + [["jvm-clt" [?x ?y]]] + (&&host/compile-jvm-clt compile-expression ?type ?x ?y) + + [["jvm-cgt" [?x ?y]]] + (&&host/compile-jvm-cgt compile-expression ?type ?x ?y) ;; Integer arithmetic [["jvm-iadd" [?x ?y]]] @@ -297,6 +307,9 @@ [["jvm-lushr" [?x ?y]]] (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) + + [["jvm-instanceof" [?class ?object]]] + (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object) ) )) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 2a8bdac89..5c2c43296 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -144,6 +144,10 @@ compile-jvm-ieq Opcodes/IF_ICMPEQ "java.lang.Integer" "intValue" "()I" compile-jvm-ilt Opcodes/IF_ICMPLT "java.lang.Integer" "intValue" "()I" compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I" + + compile-jvm-ceq Opcodes/IF_ICMPEQ "java.lang.Character" "charValue" "()C" + compile-jvm-clt Opcodes/IF_ICMPLT "java.lang.Character" "charValue" "()C" + compile-jvm-cgt Opcodes/IF_ICMPGT "java.lang.Character" "charValue" "()C" ) (do-template [ ] @@ -186,12 +190,12 @@ (defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] (|do [^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] - _ (&/map% (fn [[class-name arg]] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (map vector ?classes ?args)) + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) :let [_ (doto *writer* (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class ?class) ?method method-sig) (prepare-return! *type*))]] @@ -319,6 +323,14 @@ ;; else 0))) +(defn compile-jvm-instanceof [compile *type* class object] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile object) + :let [_ (doto *writer* + (.visitLdcInsn class) + (.visitTypeInsn Opcodes/INSTANCEOF class))]] + (return nil))) + (defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods] (|do [module &/get-module-name] (let [super-class* (&host/->class ?super-class) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 7d6b2b502..ecb614732 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -25,17 +25,6 @@ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) -(defn compile-int [compile *type* value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW "java/lang/Long") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (bit-shift-left (long value) 0) - ;; (bit-shift-left (long value) 32) - ) - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Long" "" "(J)V"))]] - (return nil))) - (do-template [ ] (defn [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer @@ -46,7 +35,7 @@ (.visitMethodInsn Opcodes/INVOKESPECIAL "" ))]] (return nil))) - ;; compile-int "java/lang/Long" "(J)V" long + compile-int "java/lang/Long" "(J)V" long compile-real "java/lang/Double" "(D)V" double compile-char "java/lang/Character" "(C)V" char ) -- cgit v1.2.3 From f5e3afe5a5337b5dc840ed0fd6a76244cf0aac6b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 19 Jul 2015 22:32:08 -0400 Subject: Added copyright notice on all files that missed it. --- input/lux/data/number.lux | 28 ++-------------------------- input/program.lux | 8 ++++++++ src/lux.clj | 8 ++++++++ src/lux/analyser.clj | 8 ++++++++ src/lux/analyser/base.clj | 8 ++++++++ src/lux/analyser/case.clj | 8 ++++++++ src/lux/analyser/env.clj | 8 ++++++++ src/lux/analyser/host.clj | 8 ++++++++ src/lux/analyser/lambda.clj | 8 ++++++++ src/lux/analyser/lux.clj | 8 ++++++++ src/lux/analyser/module.clj | 8 ++++++++ src/lux/base.clj | 8 ++++++++ src/lux/compiler.clj | 8 ++++++++ src/lux/compiler/base.clj | 8 ++++++++ src/lux/compiler/case.clj | 8 ++++++++ src/lux/compiler/host.clj | 8 ++++++++ src/lux/compiler/lambda.clj | 8 ++++++++ src/lux/compiler/lux.clj | 8 ++++++++ src/lux/host.clj | 8 ++++++++ src/lux/lexer.clj | 8 ++++++++ src/lux/optimizer.clj | 9 ++++++++- src/lux/parser.clj | 8 ++++++++ src/lux/reader.clj | 8 ++++++++ src/lux/type.clj | 8 ++++++++ 24 files changed, 186 insertions(+), 27 deletions(-) diff --git a/input/lux/data/number.lux b/input/lux/data/number.lux index 8203d2ecd..e1c10d6b0 100644 --- a/input/lux/data/number.lux +++ b/input/lux/data/number.lux @@ -15,39 +15,15 @@ ## Signatures (defsig #export (Number n) (do-template [] - [(: (-> n n n) - )] + [(: (-> n n n) )] [+] [-] [*] [/] [%]) - ## (: (-> n n n) - ## +) - - ## (: (-> n n n) - ## -) - - ## (: (-> n n n) - ## *) - - ## (: (-> n n n) - ## /) - - ## (: (-> n n n) - ## %) (: (-> Int n) from-int) (do-template [] - [(: (-> n n) - )] + [(: (-> n n) )] [negate] [signum] [abs]) - ## (: (-> n n) - ## negate) - - ## (: (-> n n) - ## signum) - - ## (: (-> n n) - ## abs) ) ## [Structures] diff --git a/input/program.lux b/input/program.lux index 19ee964e2..1bdb237b1 100644 --- a/input/program.lux +++ b/input/program.lux @@ -1,3 +1,11 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + (;import lux (lux (codata (stream #as S)) (control monoid diff --git a/src/lux.clj b/src/lux.clj index eb025f55e..0fcb33785 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux (:gen-class) (:require [lux.base :as &] diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 782ae4685..995e77fe6 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.analyser (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 11e92f7b7..9fc3f1030 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.analyser.base (:require [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 267bd1269..659b2b0f6 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.analyser.case (:require [clojure.core.match :as M :refer [match matchv]] clojure.core.match.array diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index de6bdb036..cac0f8cd4 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.analyser.env (:require [clojure.core.match :as M :refer [matchv]] clojure.core.match.array diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 918bcb8f1..68bd627fc 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.analyser.host (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [match matchv]] diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 4dd1be38f..b1b9e2c22 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.analyser.lambda (:require [clojure.core.match :as M :refer [matchv]] clojure.core.match.array diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 75881c80a..fc96fecff 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.analyser.lux (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 27aa7374c..c13be61c4 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.analyser.module (:require [clojure.string :as string] [clojure.core.match :as M :refer [matchv]] diff --git a/src/lux/base.clj b/src/lux/base.clj index e22e51473..7ed21e9bd 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.base (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 559c1179b..549f2e0a9 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.compiler (:refer-clojure :exclude [compile]) (:require (clojure [string :as string] diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 7ac48e67e..25451aae0 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.compiler.base (:require [clojure.string :as string] [clojure.java.io :as io] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 1a0a9c6bc..fc0cce31f 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.compiler.case (:require (clojure [set :as set] [template :refer [do-template]]) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 5c2c43296..1dca81857 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.compiler.host (:require (clojure [string :as string] [set :as set] diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 7b08532fe..9f4bef80c 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.compiler.lambda (:require (clojure [string :as string] [set :as set] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index ecb614732..ac3d6f56d 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.compiler.lux (:require (clojure [string :as string] [set :as set] diff --git a/src/lux/host.clj b/src/lux/host.clj index e2efd92e9..abbdb8c6d 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.host (:require (clojure [string :as string] [template :refer [do-template]]) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index fbfe1f757..bb6e54cb4 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.lexer (:require [clojure.template :refer [do-template]] (lux [base :as & :refer [|do return* return fail fail*]] diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 8b97b6ebb..5056a09e0 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.optimizer (:require [lux.analyser :as &analyser])) @@ -12,7 +20,6 @@ ;; Pre-compute constant expressions: Find function calls for which all arguments are known at compile-time and pre-calculate everything prior to compilation. ;; Convert pattern-matching on booleans into regular if-then-else structures ;; Local var aliasing. -;; Global var aliasing. ;; [Exports] (defn optimize [eval! compile-module] diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 7a3ad18aa..966c322bf 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.parser (:require [clojure.template :refer [do-template]] [clojure.core.match :as M :refer [matchv]] diff --git a/src/lux/reader.clj b/src/lux/reader.clj index bef093247..9fd9b14ea 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.reader (:require [clojure.string :as string] [clojure.core.match :as M :refer [matchv]] diff --git a/src/lux/type.clj b/src/lux/type.clj index c3a27ce2b..77fc6a2f8 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -1,3 +1,11 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + (ns lux.type (:refer-clojure :exclude [deref apply merge bound?]) (:require [clojure.core.match :as M :refer [match matchv]] -- cgit v1.2.3 From 3a760fa6c0f47f7621970b9747779f3edcc96286 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 19 Jul 2015 23:43:37 -0400 Subject: - Added a few more modules. - Added some type-tags to avoid reflection inside the compiler. --- input/lux/data/bool.lux | 33 ++++++++++++++++++++++++++++ input/lux/data/bounded.lux | 9 -------- input/lux/data/char.lux | 20 +++++++++++++++++ input/lux/data/eq.lux | 12 +--------- input/lux/data/number.lux | 53 +++++++++++++++++++++++++++++++++++++-------- input/lux/data/ord.lux | 21 +++++++----------- input/lux/data/show.lux | 13 ----------- input/lux/data/text.lux | 19 +++++++++++----- input/lux/host/java.lux | 15 +++++++------ input/lux/meta/lux.lux | 5 +++-- input/lux/meta/syntax.lux | 18 +++++++-------- input/program.lux | 4 +++- src/lux/analyser/module.clj | 1 + src/lux/compiler/base.clj | 48 +++++++++++++++++++++++----------------- 14 files changed, 170 insertions(+), 101 deletions(-) create mode 100644 input/lux/data/bool.lux create mode 100644 input/lux/data/char.lux diff --git a/input/lux/data/bool.lux b/input/lux/data/bool.lux new file mode 100644 index 000000000..d4f223612 --- /dev/null +++ b/input/lux/data/bool.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m)) + (.. (eq #as E) + (show #as S))) + +## [Structures] +(defstruct #export Bool/Eq (E;Eq Bool) + (def (E;= x y) + (if x + y + (not y)))) + +(defstruct #export Bool/Show (S;Show Bool) + (def (S;show x) + (if x "true" "false"))) + +(do-template [ ] + [(defstruct #export (m;Monoid Bool) + (def m;unit ) + (def (m;++ x y) + ( x y)))] + + [ Or/Monoid false or] + [And/Monoid true and] + ) diff --git a/input/lux/data/bounded.lux b/input/lux/data/bounded.lux index 458fbc0df..9d2dabde1 100644 --- a/input/lux/data/bounded.lux +++ b/input/lux/data/bounded.lux @@ -15,12 +15,3 @@ (: a bottom)) - -## Structure -(do-template [ ] - [(defstruct #export (Bounded ) - (def top ) - (def bottom ))] - - [ Int/Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] - [Real/Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) diff --git a/input/lux/data/char.lux b/input/lux/data/char.lux new file mode 100644 index 000000000..42e57509e --- /dev/null +++ b/input/lux/data/char.lux @@ -0,0 +1,20 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. (eq #as E) + (show #as S))) + +## [Structures] +(defstruct #export Char/Eq (E;Eq Char) + (def (E;= x y) + (_jvm_ceq x y))) + +(defstruct #export Char/Show (S;Show Char) + (def (S;show x) + ($ text:++ "#\"" (_jvm_invokevirtual java.lang.Object toString [] x []) "\""))) diff --git a/input/lux/data/eq.lux b/input/lux/data/eq.lux index 191e6a885..be3400208 100644 --- a/input/lux/data/eq.lux +++ b/input/lux/data/eq.lux @@ -8,17 +8,7 @@ (;import lux) -## Signatures +## [Signatures] (defsig #export (Eq a) (: (-> a a Bool) =)) - -## Structures -(defstruct #export Bool/Eq (Eq Bool) - (def (= x y) - (case (: (, Bool Bool) [x y]) - (\or [true true] [false false]) - true - - _ - false))) diff --git a/input/lux/data/number.lux b/input/lux/data/number.lux index e1c10d6b0..8da674d88 100644 --- a/input/lux/data/number.lux +++ b/input/lux/data/number.lux @@ -10,7 +10,8 @@ (lux/control (monoid #as m)) (lux/data (eq #as E) (ord #as O) - (bounded #as B))) + (bounded #as B) + (show #as S))) ## Signatures (defsig #export (Number n) @@ -61,11 +62,35 @@ (def E;= r=)) ## Ord -(def #export Int/Ord (O;Ord Int) - (O;ord$ Int/Eq i< i>)) +## (def #export Int/Ord (O;Ord Int) +## (O;ord$ Int/Eq i< i>)) -(def #export Real/Ord (O;Ord Real) - (O;ord$ Real/Eq r< r>)) +## (def #export Real/Ord (O;Ord Real) +## (O;ord$ Real/Eq r< r>)) + +(do-template [ ] + [(defstruct #export (O;Ord ) + (def O;_eq ) + (def O;< ) + (def (O;<= x y) + (or ( x y) + (using (E;= x y)))) + (def O;> ) + (def (O;>= x y) + (or ( x y) + (using (E;= x y)))))] + + [ Int/Ord Int Int/Eq i< i>] + [Real/Ord Real Real/Eq r< r>]) + +## Bounded +(do-template [ ] + [(defstruct #export (B;Bounded ) + (def B;top ) + (def B;bottom ))] + + [ Int/Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] + [Real/Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) ## Monoid (do-template [ <++>] @@ -77,8 +102,18 @@ [ IntMul/Monoid Int 1 i*] [RealAdd/Monoid Real 0.0 r+] [RealMul/Monoid Real 1.0 r*] - [ IntMax/Monoid Int (:: B;Int/Bounded B;bottom) (O;max Int/Ord)] - [ IntMin/Monoid Int (:: B;Int/Bounded B;top) (O;min Int/Ord)] - [RealMax/Monoid Real (:: B;Real/Bounded B;bottom) (O;max Real/Ord)] - [RealMin/Monoid Real (:: B;Real/Bounded B;top) (O;min Real/Ord)] + [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] + [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] + [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] + [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] + ) + +## Show +(do-template [ ] + [(defstruct #export (S;Show ) + (def (S;show x) + ))] + + [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] ) diff --git a/input/lux/data/ord.lux b/input/lux/data/ord.lux index 60a6cc0a8..80f2e4fb5 100644 --- a/input/lux/data/ord.lux +++ b/input/lux/data/ord.lux @@ -9,20 +9,16 @@ (;import lux (../eq #as E)) -## Signatures +## [Signatures] (defsig #export (Ord a) (: (E;Eq a) _eq) - (: (-> a a Bool) - <) - (: (-> a a Bool) - <=) - (: (-> a a Bool) - >) - (: (-> a a Bool) - >=)) + (do-template [] + [(: (-> a a Bool) )] -## Constructors + [<] [<=] [>] [>=])) + +## [Constructors] (def #export (ord$ eq < >) (All [a] (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) @@ -37,13 +33,12 @@ (or (> x y) (:: eq (E;= x y)))))) -## Functions +## [Functions] (do-template [ ] [(def #export ( ord x y) (All [a] (-> (Ord a) a a a)) - (using ord - (if ( x y) x y)))] + (if (:: ord ( x y)) x y))] [max ;;>] [min ;;<]) diff --git a/input/lux/data/show.lux b/input/lux/data/show.lux index e081b9239..f4e1cf762 100644 --- a/input/lux/data/show.lux +++ b/input/lux/data/show.lux @@ -12,16 +12,3 @@ (defsig #export (Show a) (: (-> a Text) show)) - -## Structures -(do-template [ ] - [(defstruct #export (Show ) - (def (show x) - ))] - - [Bool/Show Bool (_jvm_invokevirtual java.lang.Object toString [] x [])] - [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] - [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] - [Char/Show Char (let [char (_jvm_invokevirtual java.lang.Object toString [] x [])] - ($ text:++ "#\"" char "\""))] - [Text/Show Text x]) diff --git a/input/lux/data/text.lux b/input/lux/data/text.lux index 5f2203376..a3192a1d5 100644 --- a/input/lux/data/text.lux +++ b/input/lux/data/text.lux @@ -7,8 +7,10 @@ ## You must not remove this notice, or any other, from this software. (;import lux + (lux/control (monoid #as m)) (lux/data (eq #as E) - (ord #as O))) + (ord #as O) + (show #as S))) ## [Functions] (def #export (size x) @@ -24,11 +26,6 @@ x [(_jvm_l2i idx)])) #;None)) -(def #export (++ x y) - (-> Text Text Text) - (_jvm_invokevirtual java.lang.String concat [java.lang.String] - x [y])) - (def #export (contains? x y) (-> Text Text Bool) (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence] @@ -137,3 +134,13 @@ (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] x [y])) 0))) + +(defstruct #export Text/Show (S;Show Text) + (def (S;show x) + x)) + +(defstruct #export Text/Monoid (m;Monoid Text) + (def m;unit "") + (def (m;++ x y) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y]))) diff --git a/input/lux/host/java.lux b/input/lux/host/java.lux index 52391201d..12525d3f2 100644 --- a/input/lux/host/java.lux +++ b/input/lux/host/java.lux @@ -7,10 +7,11 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux (data list - (text #as text)) - (control (functor #as F) + (lux (control (monoid #as m) + (functor #as F) (monad #as M #refer (#only do))) + (data list + (text #as text)) (meta lux macro syntax))) @@ -124,8 +125,8 @@ (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) (do Lux/Monad [current-module get-module-name - #let [full-name (text;++ (text;replace "/" "." current-module) - name)]] + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name))]] (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) (lambda [member] (let [[modifiers name inputs output] member] @@ -139,8 +140,8 @@ [methods (*^ method-def^)]) (do Lux/Monad [current-module get-module-name - #let [full-name (text;++ (text;replace "/" "." current-module) - name) + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name)) fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) (lambda [field] (let [[modifiers name class] field] diff --git a/input/lux/meta/lux.lux b/input/lux/meta/lux.lux index 1fc739403..db3c700e6 100644 --- a/input/lux/meta/lux.lux +++ b/input/lux/meta/lux.lux @@ -13,7 +13,8 @@ (monad #as M #refer (#only do))) (lux/data list maybe - (show #as S))) + (show #as S) + (number #as N))) ## [Types] ## (deftype (Lux a) @@ -146,7 +147,7 @@ (def #export (gensym prefix state) (-> Text (Lux Syntax)) (#;Right [(update@ #;seed inc state) - (symbol$ ["__gensym__" (:: S;Int/Show (S;show (get@ #;seed state)))])])) + (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed state)))])])) (def #export (emit datum) (All [a] diff --git a/input/lux/meta/syntax.lux b/input/lux/meta/syntax.lux index 3c9a9ce2e..1fe85c32f 100644 --- a/input/lux/meta/syntax.lux +++ b/input/lux/meta/syntax.lux @@ -11,7 +11,11 @@ (lux #as l #refer (#only Lux/Monad gensym))) (lux (control (functor #as F) (monad #as M #refer (#only do))) - (data list))) + (data (eq #as E) + (bool #as b) + (char #as c) + (text #as t) + list))) ## [Utils] (def (first xy) @@ -95,12 +99,6 @@ [ local-tag^ #;TagS] ) -(def (bool:= x y) - (-> Bool Bool Bool) - (if x - y - (not y))) - (def (ident:= x y) (-> Ident Ident Bool) (let [[x1 x2] x @@ -120,11 +118,11 @@ _ #;None))] - [ bool?^ Bool #;BoolS bool:=] + [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)] [ int?^ Int #;IntS i=] [ real?^ Real #;RealS r=] - ## [ char?^ Char #;CharS char:=] - [ text?^ Text #;TextS text:=] + [ char?^ Char #;CharS (:: c;Char/Eq E;=)] + [ text?^ Text #;TextS (:: t;Text/Eq E;=)] [symbol?^ Ident #;SymbolS ident:=] [ tag?^ Ident #;TagS ident:=] ) diff --git a/input/program.lux b/input/program.lux index 1bdb237b1..984d8610f 100644 --- a/input/program.lux +++ b/input/program.lux @@ -13,7 +13,9 @@ monad lazy comonad) - (data bounded + (data bool + bounded + char ## cont dict (either #as e) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index c13be61c4..9b68fb680 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -7,6 +7,7 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.module + (:refer-clojure :exclude [alias]) (:require [clojure.string :as string] [clojure.core.match :as M :refer [matchv]] clojure.core.match.array diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 25451aae0..68c3b7d6c 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -18,31 +18,35 @@ (:import (org.objectweb.asm Opcodes Label ClassWriter - MethodVisitor))) + MethodVisitor) + (java.io File + BufferedOutputStream + FileOutputStream) + (java.lang.reflect Field))) ;; [Utils] (defn ^:private write-file [^String file ^bytes data] - (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))] + (with-open [stream (BufferedOutputStream. (FileOutputStream. file))] (.write stream data))) (defn ^:private write-output [module name data] (let [module* module] - (.mkdirs (java.io.File. (str "output/jvm/" module*))) + (.mkdirs (File. (str "output/jvm/" module*))) (write-file (str "output/jvm/" module* "/" name ".class") data))) (defn ^:private write-cache [module name data] (let [module* (string/replace module #"/" " ")] - (.mkdirs (java.io.File. (str "cache/jvm/" module*))) + (.mkdirs (File. (str "cache/jvm/" module*))) (write-file (str "cache/jvm/" module* "/" name ".class") data))) -(defn ^:private clean-file [^java.io.File file] +(defn ^:private clean-file [^File file] (if (.isDirectory file) (do (doseq [f (seq (.listFiles file))] (clean-file f)) (.delete file)) (.delete file))) -(defn ^:private read-file [file] +(defn ^:private read-file [^File file] (with-open [reader (io/input-stream file)] (let [length (.length file) buffer (byte-array length)] @@ -74,11 +78,11 @@ (return nil))) (defn cached? [module] - (.exists (java.io.File. (str "cache/jvm/" (string/replace module #"/" " ") "/_.class")))) + (.exists (File. (str "cache/jvm/" (string/replace module #"/" " ") "/_.class")))) (defn delete-cache [module] (fn [state] - (do (clean-file (java.io.File. (str "cache/jvm/" (string/replace module #"/" " ")))) + (do (clean-file (File. (str "cache/jvm/" (string/replace module #"/" " ")))) (return* state nil)))) (defn ^:private replace-several [content & replacements] @@ -90,7 +94,7 @@ (throw e))) content replacement-list))) -(defn ^:private replace-cache [cache-name] +(defn ^:private replace-cache [^String cache-name] (if (.startsWith cache-name "$") (replace-several cache-name #"_ASTER_" "*" @@ -118,16 +122,19 @@ #"_PIPE_" "|") cache-name)) +(defn ^:private get-field [^String field-name ^Class class] + (-> class ^Field (.getField field-name) (.get nil))) + (defn load-cache [module module-hash compile-module] (|do [loader &/loader !classes &/classes] (let [module-path (str "cache/jvm/" (string/replace module #"/" " ")) module* (string/replace module #"/" ".") class-name (str module* "._") - module-meta (do (swap! !classes assoc class-name (read-file (java.io.File. (str module-path "/_.class")))) - (load-class! loader class-name))] - (if (and (= module-hash (-> module-meta (.getField "_hash") (.get nil))) - (= version (-> module-meta (.getField "_compiler") (.get nil)))) + ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (load-class! loader class-name))] + (if (and (= module-hash (get-field "_hash" module-meta)) + (= version (get-field "_compiler" module-meta))) (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") ;; _ (prn module 'imports imports) ] @@ -137,9 +144,10 @@ (&/|list) (&/->list imports)))] (if (->> loads &/->seq (every? true?)) - (do (doseq [file (seq (.listFiles (java.io.File. module-path))) - :when (not= "_.class" (.getName file))] - (let [real-name (second (re-find #"^(.*)\.class$" (.getName file))) + (do (doseq [^File file (seq (.listFiles (File. module-path))) + :let [file-name (.getName file)] + :when (not= "_.class" file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) bytecode (read-file file) ;; _ (prn 'load-cache module real-name) ] @@ -149,18 +157,18 @@ ;; (swap! !classes assoc (-> (load-class! loader "__temp__") (.getField "_name") (.get nil)) bytecode) (write-output module real-name bytecode))) ;; (swap! !classes dissoc "__temp__") - (let [defs (string/split (-> module-meta (.getField "_defs") (.get nil)) #"\t")] + (let [defs (string/split (get-field "_defs" module-meta) #"\t")] (|do [_ (fn [state] (&/run-state (&/map% (fn [_def] (let [[_exported? _name _ann] (string/split _def #" ") ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) def-class (load-class! loader (str module* ".$" (&/normalize-ident _name))) - def-name (-> def-class (.getField "_name") (.get nil))] + def-name (get-field "_name" def-class)] (|do [_ (case _ann "T" (&a-module/define module def-name (&/V "lux;TypeD" nil) &type/Type) "M" (|do [_ (&a-module/define module def-name (&/V "lux;ValueD" &type/Macro) &type/Macro)] (&a-module/declare-macro module def-name)) - "V" (let [def-type (-> def-class (.getField "_meta") (.get nil))] + "V" (let [def-type (get-field "_meta" def-class)] (matchv ::M/objects [def-type] [["lux;ValueD" _def-type]] (&a-module/define module def-name def-type _def-type))) @@ -168,7 +176,7 @@ (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] (|do [__type (&a-module/def-type __module __name)] (do ;; (prn '__type [__module __name] (&type/show-type __type)) - (&a-module/def-alias module def-name __module __name __type)))))] + (&a-module/def-alias module def-name __module __name __type)))))] (if (= "1" _exported?) (&a-module/export module def-name) (return nil))) -- cgit v1.2.3 From 874af34a80ab799d0470810b7ade337b96ce50bc Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 21 Jul 2015 01:03:37 -0400 Subject: - Added a way to pass the cursor from un-expanded macro-forms to their expansions in order to aid error-reporting. - Added recursive type definitions through the #rec tag in deftype. --- input/lux.lux | 105 +++++++++++++++++++++++++++++++++++++-------- input/lux/control/lazy.lux | 2 +- src/lux/analyser.clj | 2 +- src/lux/analyser/lux.clj | 12 ++++-- 4 files changed, 98 insertions(+), 23 deletions(-) diff --git a/input/lux.lux b/input/lux.lux index 0c8b73c34..7ba6cef76 100644 --- a/input/lux.lux +++ b/input/lux.lux @@ -295,6 +295,12 @@ (_lux_export Macro) ## Base functions & macros +## (def _cursor +## Cursor +## ["" -1 -1]) +(_lux_def _cursor + (_lux_: Cursor ["" -1 -1])) + ## (def (_meta data) ## (-> (Syntax' (Meta Cursor)) Syntax) ## (#Meta [["" -1 -1] data])) @@ -303,7 +309,7 @@ (#AppT [Meta Cursor])]) Syntax]) (_lux_lambda _ data - (#Meta [["" -1 -1] data])))) + (#Meta [_cursor data])))) ## (def (return x) ## (All [a] @@ -1488,21 +1494,34 @@ _ (fail "Wrong syntax for :!"))) +(def'' (empty? xs) + (All [a] (-> ($' List a) Bool)) + (_lux_case xs + #Nil true + _ false)) + (defmacro #export (deftype tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case (:! (List Syntax) tokens) + (_lux_case tokens (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true (:! (List Syntax) tokens')] + [true tokens'] _ - [false (:! (List Syntax) tokens)])) - parts (: (Maybe (, Syntax (List Syntax) Syntax)) + [false tokens])) + [rec? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) + [true tokens'] + + _ + [false tokens'])) + parts (: (Maybe (, Text (List Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) - (#Some [(symbol$ name) #Nil type]) + (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) + (#Some [name #Nil type]) - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) - (#Some [(symbol$ name) args type]) + (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) + (#Some [name args type]) _ #None))] @@ -1510,21 +1529,71 @@ (#Some [name args type]) (let [with-export (: (List Syntax) (if export? - (list (`' (_lux_export (~ name)))) + (list (`' (_lux_export (~ (symbol$ ["" name]))))) #Nil)) - type' (: Syntax - (_lux_case args - #Nil - type + type' (: (Maybe Syntax) + (if rec? + (if (empty? args) + (let [g!param (symbol$ ["" ""]) + prime-name (symbol$ ["" (text:++ name "'")]) + type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] + (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) + ;Void)))) + #None) + (_lux_case args + #Nil + (#Some type) - _ - (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (list& (`' (_lux_def (~ name) (;type (~ type')))) - with-export))) + _ + (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] + (_lux_case type' + (#Some type'') + (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) + with-export)) + + #None + (fail "Wrong syntax for deftype"))) #None (fail "Wrong syntax for deftype")) )) +## (defmacro #export (deftype tokens) +## (let [[export? tokens'] (: (, Bool (List Syntax)) +## (_lux_case (:! (List Syntax) tokens) +## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) +## [true (:! (List Syntax) tokens')] + +## _ +## [false (:! (List Syntax) tokens)])) +## parts (: (Maybe (, Syntax (List Syntax) Syntax)) +## (_lux_case tokens' +## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) +## (#Some [(symbol$ name) #Nil type]) + +## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) +## (#Some [(symbol$ name) args type]) + +## _ +## #None))] +## (_lux_case parts +## (#Some [name args type]) +## (let [with-export (: (List Syntax) +## (if export? +## (list (`' (_lux_export (~ name)))) +## #Nil)) +## type' (: Syntax +## (_lux_case args +## #Nil +## type + +## _ +## (`' (;All (~ name) [(~@ args)] (~ type)))))] +## (return (list& (`' (_lux_def (~ name) (;type (~ type')))) +## with-export))) + +## #None +## (fail "Wrong syntax for deftype")) +## )) (defmacro #export (exec tokens) (_lux_case (reverse tokens) diff --git a/input/lux/control/lazy.lux b/input/lux/control/lazy.lux index fca63179e..22dac74fe 100644 --- a/input/lux/control/lazy.lux +++ b/input/lux/control/lazy.lux @@ -36,7 +36,7 @@ ## Structs (defstruct #export Lazy/Functor (Functor Lazy) (def (F;map f ma) - (... (f (! ma))))) + (lambda [k] (ma (. k f))))) (defstruct #export Lazy/Monad (Monad Lazy) (def M;_functor Lazy/Functor) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 995e77fe6..f85b3d619 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -535,7 +535,7 @@ ] [["lux;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) exo-type =fn ?args) state*)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type meta =fn ?args) state*)) [_] ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index fc96fecff..8be2a8924 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -30,6 +30,11 @@ (return (&/T ?item =type))) ))))) +(defn ^:private with-cursor [cursor form] + (matchv ::M/objects [form] + [["lux;Meta" [_ syntax]]] + (&/V "lux;Meta" (&/T cursor syntax)))) + ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] (|do [exo-type* (&type/actual-type exo-type)] @@ -245,7 +250,7 @@ (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) )) -(defn analyse-apply [analyse exo-type =fn ?args] +(defn analyse-apply [analyse exo-type form-cursor =fn ?args] (|do [loader &/loader] (matchv ::M/objects [=fn] [[=fn-form =fn-type]] @@ -255,14 +260,15 @@ (matchv ::M/objects [$def] [["lux;MacroD" macro]] (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) + :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] :let [_ (when (and ;; (= "lux/control/monad" ?module) (= "case" ?name)) - (->> (&/|map &/show-ast macro-expansion) + (->> (&/|map &/show-ast macro-expansion*) (&/|interpose "\n") (&/fold str "") (prn ?module "case")))] ] - (&/flat-map% (partial analyse exo-type) macro-expansion)) + (&/flat-map% (partial analyse exo-type) macro-expansion*)) [_] (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] -- cgit v1.2.3 From 1fd2fc0ff67f76177d4addc13faae5d0e95773d3 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 24 Jul 2015 19:19:16 -0400 Subject: - Fixed an error when compiling Java field access (both static & virtual). - Fixed some errors regarding cache loading. --- src/lux.clj | 2 +- src/lux/analyser/lux.clj | 39 ++++++------ src/lux/analyser/module.clj | 82 ++++++++++++------------ src/lux/base.clj | 21 ++++++- src/lux/compiler.clj | 89 +++++++++++++------------- src/lux/compiler/base.clj | 149 +++++++++++++++++++++++--------------------- src/lux/compiler/host.clj | 10 ++- src/lux/compiler/lux.clj | 2 +- 8 files changed, 209 insertions(+), 185 deletions(-) diff --git a/src/lux.clj b/src/lux.clj index 0fcb33785..7ff8fda37 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -14,7 +14,7 @@ :reload-all)) (defn -main [& _] - (do (time (&compiler/compile-all (&/|list "program"))) + (do (time (&compiler/compile-all (&/|list "lux" "program"))) ;; (prn @&type/counter) ) (System/exit 0)) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 8be2a8924..72923c43e 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -261,12 +261,12 @@ [["lux;MacroD" macro]] (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - :let [_ (when (and ;; (= "lux/control/monad" ?module) - (= "case" ?name)) - (->> (&/|map &/show-ast macro-expansion*) - (&/|interpose "\n") - (&/fold str "") - (prn ?module "case")))] + ;; :let [_ (when (and ;; (= "lux/control/monad" ?module) + ;; (= "case" ?name)) + ;; (->> (&/|map &/show-ast macro-expansion*) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (prn ?module "case")))] ] (&/flat-map% (partial analyse exo-type) macro-expansion*)) @@ -388,21 +388,18 @@ (return (&/|list (&/V "declare-macro" (&/T module-name ?name)))))) (defn analyse-import [analyse compile-module ?path] - (|do [module-name &/get-module-name] - (if (= module-name ?path) - (fail (str "[Analyser Error] Module can't import itself: " ?path)) - (&/save-module - (fn [state] - (let [already-compiled? (&/fold #(or %1 (= %2 ?path)) false (&/get$ &/$SEEN-SOURCES state))] - (prn 'analyse-import module-name ?path already-compiled?) - (&/run-state (|do [_ (&&module/add-import ?path) - _ (if already-compiled? - (return nil) - (compile-module ?path))] - (return (&/|list))) - (if already-compiled? - state - (&/update$ &/$SEEN-SOURCES (partial &/|cons ?path) state))))))))) + (|do [module-name &/get-module-name + _ (if (= module-name ?path) + (fail (str "[Analyser Error] Module can't import itself: " ?path)) + (return nil))] + (&/save-module + (|do [already-compiled? (&/source-seen? ?path) + :let [must-compile? (not already-compiled?) + _ (prn 'analyse-import module-name ?path already-compiled?)] + _ (&/when% must-compile? (&/see-source ?path)) + _ (&&module/add-import ?path) + _ (&/when% must-compile? (compile-module ?path))] + (return (&/|list)))))) (defn analyse-export [analyse name] (|do [module-name &/get-module-name diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 9b68fb680..830319549 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -20,9 +20,7 @@ (def ^:private $DEFS 0) (def ^:private $ALIASES 1) (def ^:private $IMPORTS 2) - -;; [Exports] -(def init-module +(def ^:private +init+ (&/R ;; "lux;defs" (&/|table) ;; "lux;module-aliases" @@ -31,6 +29,7 @@ (&/|list) )) +;; [Exports] (defn add-import [module] "(-> Text (Lux (,)))" (|do [current-module &/get-module-name] @@ -55,15 +54,7 @@ (&/update$ $DEFS #(&/|put name (&/T false def-data) %) m)) - ms))) - ;; (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] - ;; (&/update$ &/$MAPPINGS (fn [mappings] - ;; (&/|put (str "" &/+name-separator+ name) - ;; (&/T (&/V "lux;Global" (&/T module name)) type) - ;; mappings)) - ;; locals)) - ;; ?env))) - ) + ms)))) nil) [_] @@ -75,18 +66,21 @@ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] (matchv ::M/objects [$def] - [["lux;TypeD" _]] + [[_ ["lux;TypeD" _]]] (return* state &type/Type) - [["lux;MacroD" _]] + [[_ ["lux;MacroD" _]]] (return* state &type/Macro) - [["lux;ValueD" _type]] + [[_ ["lux;ValueD" _type]]] (return* state _type) - [["lux;AliasD" [?r-module ?r-name]]] + [[_ ["lux;AliasD" [?r-module ?r-name]]]] (&/run-state (def-type ?r-module ?r-name) - state)) + state) + + [_] + (assert false (prn-str 'def-type (str module ";" name) (aget $def 0)))) (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) (fail* (str "[Analyser Error] Unknown module: " module))))) @@ -103,16 +97,7 @@ (&/update$ $DEFS #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %) m)) - ms))) - ;; (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] - ;; (&/update$ &/$MAPPINGS (fn [mappings] - ;; (&/|put (str "" &/+name-separator+ a-name) - ;; (&/T (&/V "lux;Global" (&/T r-module r-name)) type) - ;; ;; (aget (->> state (&/get$ &/$MODULES) (&/|get r-module) (&/get$ $DEFS) (&/|get r-name)) 1) - ;; mappings)) - ;; locals)) - ;; ?env))) - ) + ms)))) nil) [_] @@ -150,7 +135,12 @@ ;; (prn 'find-def/_0 module name 'current-module current-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 (try (->> $module (&/get$ $DEFS) (&/|get name)) + (catch StackOverflowError e + (assert false (prn-str 'find-def + (str module ";" name) + (&/->seq (&/|keys (&/get$ $DEFS $module))) + (&/->seq (&/|keys (&/get$ &/$MODULES state)))))))] (matchv ::M/objects [$def] [[exported? $$def]] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) @@ -165,10 +155,7 @@ (return* state (&/T (&/T module name) $$def))) (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) - (do (prn [module name] - (str "[Analyser Error] Module doesn't exist: " module) - (->> state (&/get$ &/$MODULES) &/|keys &/->seq)) - (fail* (str "[Analyser Error] Module doesn't exist: " module))))))) + (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) (defn defined? [module name] (&/try-all% (&/|list (|do [_ (find-def module name)] @@ -239,21 +226,32 @@ (matchv ::M/objects [v] [[?exported? ?def]] (do ;; (prn 'defs k ?exported?) - (matchv ::M/objects [?def] - [["lux;AliasD" [?r-module ?r-name]]] - (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) - - [["lux;MacroD" _]] - (&/T ?exported? k "M") + (matchv ::M/objects [?def] + [["lux;AliasD" [?r-module ?r-name]]] + (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) + + [["lux;MacroD" _]] + (&/T ?exported? k "M") - [["lux;TypeD" _]] - (&/T ?exported? k "T") + [["lux;TypeD" _]] + (&/T ?exported? k "T") - [_] - (&/T ?exported? k "V")))))) + [_] + (&/T ?exported? k "V")))))) (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))))))) (def imports (|do [module &/get-module-name] (fn [state] (return* state (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $IMPORTS)))))) + +(defn create-module [name] + (fn [state] + (return* (&/update$ &/$MODULES #(&/|put name +init+ %) state) nil))) + +(defn enter-module [name] + (fn [state] + (return* (->> state + (&/update$ &/$MODULES #(&/|put name +init+ %)) + (&/set$ &/$ENVS (&/|list (&/env name)))) + nil))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 7ed21e9bd..7b1e7139e 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -468,7 +468,7 @@ ;; (prn 'findClass class-name) (if-let [^bytes bytecode (get @store class-name)] (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) - (do (prn 'memory-class-loader/store (keys @store)) + (do (prn 'memory-class-loader/store class-name (keys @store)) (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))) (defn host [_] @@ -477,7 +477,6 @@ store ;; "lux;loader" (memory-class-loader store) - ;; (-> (java.io.File. "./output/") .toURL vector into-array java.net.URLClassLoader.) ;; "lux;writer" (V "lux;None" nil)))) @@ -493,7 +492,7 @@ ;; "lux;seed" 0 ;; "lux;seen-sources" - (|list "lux") + (|list) ;; "lux;source" (V "lux;None" nil) ;; "lux;types" @@ -711,3 +710,19 @@ (defn enumerate [xs] (enumerate* 0 xs)) + +(defn source-seen? [path] + "(-> Text (Lux Bool))" + (fn [state] + (return* state (fold #(or %1 (= %2 path)) false (get$ $SEEN-SOURCES state))))) + +(defn see-source [path] + "(-> Text (Lux (,)))" + (fn [state] + (return* (update$ $SEEN-SOURCES (partial |cons path) state) nil))) + +(defn when% [test body] + "(-> Bool (Lux (,)) (Lux (,)))" + (if test + body + (return nil))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 549f2e0a9..fbf8afb89 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -372,52 +372,53 @@ ;; (prn 'compile-module name) (if (&&/cached? name) (do ;; (println "YOLO") - (let [file-name (str "input/" name ".lux") - file-content (slurp file-name)] - (&&/load-cache name (hash file-content) compile-module))) + (let [file-name (str "input/" name ".lux") + file-content (slurp file-name)] + (&&/load-cache name (hash file-content) compile-module))) (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] (&/map% compile-statement analysis+))] - (fn [state] - (if (->> state (&/get$ &/$MODULES) (&/|contains? name)) + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? (if (.equals ^Object name "lux") - (return* state nil) - (fail* "[Compiler Error] Can't redefine a module!")) - (let [file-name (str "input/" name ".lux") - file-content (slurp file-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str name "/_") nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil (hash file-content)) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) - .visitEnd))] - (matchv ::M/objects [((&/exhaust% compiler-step) - (->> state - (&/set$ &/$SOURCE (&reader/from file-name file-content)) - (&/set$ &/$ENVS (&/|list (&/env name))) - (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %)) - (&/update$ &/$MODULES #(&/|put name &a-module/init-module %))))] - [["lux;Right" [?state _]]] - (&/run-state (|do [defs &a-module/defs - imports &a-module/imports - :let [_ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil - (->> defs - (&/|map (fn [_def] - (|let [[?exported ?name ?ann] _def] - (str (if ?exported "1" "0") " " ?name " " ?ann)))) - (&/|interpose "\t") - (&/fold str ""))) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil - (->> imports (&/|interpose "\t") (&/fold str ""))) - .visitEnd) - (.visitEnd))]] - (&&/save-class! "_" (.toByteArray =class))) - ?state) - - [["lux;Left" ?message]] - (fail* ?message)))))))) + (return nil) + (fail "[Compiler Error] Can't redefine a module!")) + (|do [_ (&a-module/enter-module name) + :let [file-name (str "input/" name ".lux") + file-content (slurp file-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (str name "/_") nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil (hash file-content)) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) + .visitEnd))]] + (fn [state] + (matchv ::M/objects [((&/exhaust% compiler-step) + (->> state + (&/set$ &/$SOURCE (&reader/from file-name file-content)) + (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %))))] + [["lux;Right" [?state _]]] + (&/run-state (|do [defs &a-module/defs + imports &a-module/imports + :let [_ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil + (->> defs + (&/|map (fn [_def] + (|let [[?exported ?name ?ann] _def] + (str (if ?exported "1" "0") " " ?name " " ?ann)))) + (&/|interpose "\t") + (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil + (->> imports (&/|interpose "\t") (&/fold str ""))) + .visitEnd) + (.visitEnd))]] + (&&/save-class! "_" (.toByteArray =class))) + ?state) + + [["lux;Left" ?message]] + (fail* ?message))))))) + )) (defn ^:private clean-file [^java.io.File file] (if (.isDirectory file) @@ -437,7 +438,7 @@ ;; [Resources] (defn compile-all [modules] (setup-dirs!) - (matchv ::M/objects [((&/map% compile-module (&/|cons "lux" modules)) (&/init-state nil))] + (matchv ::M/objects [((&/map% compile-module modules) (&/init-state nil))] [["lux;Right" [?state _]]] (println (str "Compilation complete! " (str "[" (->> modules (&/|interpose " ") diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 68c3b7d6c..89303c48d 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -62,6 +62,7 @@ (def apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") (defn load-class! [^ClassLoader loader name] + ;; (prn 'load-class! name) (.loadClass loader name)) (defn save-class! [name bytecode] @@ -123,76 +124,84 @@ cache-name)) (defn ^:private get-field [^String field-name ^Class class] - (-> class ^Field (.getField field-name) (.get nil))) + (-> class ^Field (.getField field-name) (.get nil)) + ;; (try (-> class ^Field (.getField field-name) (.get nil)) + ;; (catch Error e + ;; (assert false (prn-str 'get-field field-name class)))) + ) (defn load-cache [module module-hash compile-module] (|do [loader &/loader - !classes &/classes] - (let [module-path (str "cache/jvm/" (string/replace module #"/" " ")) - module* (string/replace module #"/" ".") - class-name (str module* "._") - ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) - (load-class! loader class-name))] - (if (and (= module-hash (get-field "_hash" module-meta)) - (= version (get-field "_compiler" module-meta))) - (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") - ;; _ (prn module 'imports imports) - ] - (|do [loads (&/map% (fn [_import] - (load-cache _import (-> (str "input/" _import ".lux") slurp hash) compile-module)) - (if (= [""] imports) - (&/|list) - (&/->list imports)))] - (if (->> loads &/->seq (every? true?)) - (do (doseq [^File file (seq (.listFiles (File. module-path))) - :let [file-name (.getName file)] - :when (not= "_.class" file-name)] - (let [real-name (second (re-find #"^(.*)\.class$" file-name)) - bytecode (read-file file) - ;; _ (prn 'load-cache module real-name) - ] - ;; (swap! !classes assoc (str module* "." (replace-cache real-name)) bytecode) - (swap! !classes assoc (str module* "." real-name) bytecode) - ;; (swap! !classes assoc "__temp__" bytecode) - ;; (swap! !classes assoc (-> (load-class! loader "__temp__") (.getField "_name") (.get nil)) bytecode) - (write-output module real-name bytecode))) - ;; (swap! !classes dissoc "__temp__") - (let [defs (string/split (get-field "_defs" module-meta) #"\t")] - (|do [_ (fn [state] - (&/run-state (&/map% (fn [_def] - (let [[_exported? _name _ann] (string/split _def #" ") - ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) - def-class (load-class! loader (str module* ".$" (&/normalize-ident _name))) - def-name (get-field "_name" def-class)] - (|do [_ (case _ann - "T" (&a-module/define module def-name (&/V "lux;TypeD" nil) &type/Type) - "M" (|do [_ (&a-module/define module def-name (&/V "lux;ValueD" &type/Macro) &type/Macro)] - (&a-module/declare-macro module def-name)) - "V" (let [def-type (get-field "_meta" def-class)] - (matchv ::M/objects [def-type] - [["lux;ValueD" _def-type]] - (&a-module/define module def-name def-type _def-type))) - ;; else - (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] - (|do [__type (&a-module/def-type __module __name)] - (do ;; (prn '__type [__module __name] (&type/show-type __type)) - (&a-module/def-alias module def-name __module __name __type)))))] - (if (= "1" _exported?) - (&a-module/export module def-name) - (return nil))) - )) - (if (= [""] defs) - (&/|list) - (&/->list defs))) - (->> state - (&/set$ &/$ENVS (&/|list (&/env module))) - (&/update$ &/$MODULES #(&/|put module &a-module/init-module %)))))] - (return true)))) - (|do [_ (delete-cache module) - _ (compile-module module)] - (return false))))) - - (|do [_ (delete-cache module) - _ (compile-module module)] - (return false))) - ))) + !classes &/classes + already-loaded? (&/source-seen? module) + :let [redo-cache (|do [_ (delete-cache module) + _ (compile-module module)] + (return false))]] + (if already-loaded? + (return true) + (if (cached? module) + (do (prn 'load-cache module module-hash) + (let [module-path (str "cache/jvm/" (string/replace module #"/" " ")) + module* (string/replace module #"/" ".") + class-name (str module* "._") + ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (load-class! loader class-name))] + (if (and (= module-hash (get-field "_hash" module-meta)) + (= version (get-field "_compiler" module-meta))) + (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") + ;; _ (prn module 'imports imports) + ] + (|do [loads (&/map% (fn [_import] + (load-cache _import (-> (str "input/" _import ".lux") slurp hash) compile-module)) + (if (= [""] imports) + (&/|list) + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (do (doseq [^File file (seq (.listFiles (File. module-path))) + :let [file-name (.getName file)] + :when (not= "_.class" file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) + bytecode (read-file file) + ;; _ (prn 'load-cache module real-name) + ] + ;; (swap! !classes assoc (str module* "." (replace-cache real-name)) bytecode) + (swap! !classes assoc (str module* "." real-name) bytecode) + ;; (swap! !classes assoc "__temp__" bytecode) + ;; (swap! !classes assoc (-> (load-class! loader "__temp__") (.getField "_name") (.get nil)) bytecode) + (write-output module real-name bytecode))) + ;; (swap! !classes dissoc "__temp__") + (let [defs (string/split (get-field "_defs" module-meta) #"\t")] + ;; (prn 'load-cache module defs) + (|do [_ (&/see-source module) + _ (&a-module/enter-module module) + _ (&/map% (fn [_def] + (let [[_exported? _name _ann] (string/split _def #" ") + ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) + ] + (|do [_ (case _ann + "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) + "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] + (&a-module/declare-macro module _name)) + "V" (let [def-class (load-class! loader (str module* ".$" (&/normalize-ident _name))) + ;; _ (println "Fetching _meta" module _name (str module* ".$" (&/normalize-ident _name)) def-class) + def-type (get-field "_meta" def-class)] + (matchv ::M/objects [def-type] + [["lux;ValueD" _def-type]] + (&a-module/define module _name def-type _def-type))) + ;; else + (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] + (|do [__type (&a-module/def-type __module __name)] + (do ;; (prn '__type [__module __name] (&type/show-type __type)) + (&a-module/def-alias module _name __module __name __type)))))] + (if (= "1" _exported?) + (&a-module/export module _name) + (return nil))) + )) + (if (= [""] defs) + (&/|list) + (&/->list defs)))] + (return true)))) + redo-cache))) + redo-cache) + )) + redo-cache)))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 1dca81857..fd34a45a7 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -292,14 +292,18 @@ (defn compile-jvm-getstatic [compile *type* ?class ?field] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]] + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*)) + (prepare-return! *type*))]] (return nil))) (defn compile-jvm-getfield [compile *type* ?class ?field ?object] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] - :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]] + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST (&host/->class ?class)) + (.visitFieldInsn Opcodes/GETFIELD (&host/->class ?class) ?field (&host/->java-sig *type*)) + (prepare-return! *type*))]] (return nil))) (defn compile-jvm-putstatic [compile *type* ?class ?field ?value] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index ac3d6f56d..66db6923d 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -87,7 +87,7 @@ ret (compile v) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return ret)))) - (&/|range num-elems) elems*)] + (&/|range num-elems) elems*)] (return nil))) (defn compile-variant [compile *type* ?tag ?value] -- cgit v1.2.3 From 23b51269d8d0e1d756d019a6bf28ec24b6a507e1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 24 Jul 2015 23:09:26 -0400 Subject: - Removed the "seen-sources" field from the compiler state. - Fixed the caching mechanism. --- input/lux.lux | 36 ++++++------ input/lux/meta/lux.lux | 6 +- src/lux/analyser/lux.clj | 8 +-- src/lux/base.clj | 18 ++---- src/lux/compiler.clj | 2 +- src/lux/compiler/base.clj | 140 +++++++++++++++++++++++----------------------- src/lux/type.clj | 1 - 7 files changed, 102 insertions(+), 109 deletions(-) diff --git a/input/lux.lux b/input/lux.lux index 7ba6cef76..3bd4d58d0 100644 --- a/input/lux.lux +++ b/input/lux.lux @@ -267,7 +267,6 @@ ## #types (Bindings Int Type) ## #host HostState ## #seed Int -## #seen-sources (List Text) ## #eval? Bool)) (_lux_def Compiler (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" @@ -280,9 +279,8 @@ (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] (#Cons [["lux;host" HostState] (#Cons [["lux;seed" Int] - (#Cons [["lux;seen-sources" (#AppT [List Text])] - (#Cons [["lux;eval?" Bool] - #Nil])])])])])])])]))]) + (#Cons [["lux;eval?" Bool] + #Nil])])])])])])]))]) Void])) (_lux_export Compiler) @@ -1299,7 +1297,7 @@ (_lux_case state {#source source #modules modules #envs envs #types types #host host - #seed seed #seen-sources seen-sources #eval? eval?} + #seed seed #eval? eval?} (_lux_case (reverse envs) #Nil (#Left "Can't get the module name without a module!") @@ -1338,7 +1336,7 @@ (_lux_case state {#source source #modules modules #envs envs #types types #host host - #seed seed #seen-sources seen-sources #eval? eval?} + #seed seed #eval? eval?} (#Right [state (find-macro' modules current-module module name)])))))) (def'' (list:join xs) @@ -1396,7 +1394,7 @@ (as-pairs tokens))] (;return (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) -(def'' (->text x) +(def'' #export (->text x) (-> (^ java.lang.Object) Text) (_jvm_invokevirtual java.lang.Object toString [] x [])) @@ -1735,10 +1733,10 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #seen-sources seen-sources #eval? eval?} + #seed seed #eval? eval?} (#Right [{#source source #modules modules #envs envs #types types #host host - #seed (inc seed) #seen-sources seen-sources #eval? eval?} + #seed (inc seed) #eval? eval?} (symbol$ ["__gensym__" (->text seed)])]))) (def (macro-expand-1 token) @@ -1986,7 +1984,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #seen-sources seen-sources #eval? eval?} + #seed seed #eval? eval?} (case (get module modules) (#Some =module) (#Right [state true]) @@ -2000,7 +1998,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #seen-sources seen-sources #eval? eval?} + #seed seed #eval? eval?} (case (get module modules) (#Some =module) (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) @@ -2190,9 +2188,13 @@ _ (;return (: (List Syntax) (list:++ (map (lambda [m-name] - (` (_lux_import (~ (text$ m-name))))) + (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [($ text:++ "lux;import " m-name "\n")]) + (` (_lux_import (~ (text$ m-name)))))) unknowns) - (list (` (import (~@ tokens)))))))))) + (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) ["\n"]) + (list (` (import (~@ tokens))))))))))) (def (some f xs) (All [a b] @@ -2399,7 +2401,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #seen-sources seen-sources #eval? eval?} + #seed seed #eval? eval?} (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) (lambda [env] (case env @@ -2449,7 +2451,7 @@ (let [[v-prefix v-name] name {#source source #modules modules #envs envs #types types #host host - #seed seed #seen-sources seen-sources #eval? eval?} state] + #seed seed #eval? eval?} state] (case (get v-prefix modules) #None #None @@ -2472,7 +2474,7 @@ ## (let [[v-prefix v-name] name ## {#source source #modules modules ## #envs envs #types types #host host -## #seed seed #seen-sources seen-sources #eval? eval?} state] +## #seed seed #eval? eval?} state] ## (do Maybe/Monad ## [module (get v-prefix modules) ## #let [{#defs defs #module-aliases _ #imports _} module] @@ -2501,7 +2503,7 @@ _ (let [{#source source #modules modules #envs envs #types types #host host - #seed seed #seen-sources seen-sources #eval? eval?} state] + #seed seed #eval? eval?} state] (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) (defmacro #export (using tokens) diff --git a/input/lux/meta/lux.lux b/input/lux/meta/lux.lux index db3c700e6..a28d6e5d4 100644 --- a/input/lux/meta/lux.lux +++ b/input/lux/meta/lux.lux @@ -227,7 +227,7 @@ (case state {#;source source #;modules modules #;envs envs #;types types #;host host - #;seed seed #;seen-sources seen-sources #;eval? eval?} + #;seed seed #;eval? eval?} (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) (lambda [env] (case env @@ -247,7 +247,7 @@ (let [[v-prefix v-name] name {#;source source #;modules modules #;envs envs #;types types #;host host - #;seed seed #;seen-sources seen-sources #;eval? eval?} state] + #;seed seed #;eval? eval?} state] (case (get v-prefix modules) #;None #;None @@ -282,6 +282,6 @@ _ (let [{#;source source #;modules modules #;envs envs #;types types #;host host - #;seed seed #;seen-sources seen-sources #;eval? eval?} state] + #;seed seed #;eval? eval?} state] (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) )) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 72923c43e..6acae193f 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -393,12 +393,10 @@ (fail (str "[Analyser Error] Module can't import itself: " ?path)) (return nil))] (&/save-module - (|do [already-compiled? (&/source-seen? ?path) - :let [must-compile? (not already-compiled?) - _ (prn 'analyse-import module-name ?path already-compiled?)] - _ (&/when% must-compile? (&/see-source ?path)) + (|do [already-compiled? (&&module/exists? ?path) + :let [_ (prn 'analyse-import module-name ?path already-compiled?)] _ (&&module/add-import ?path) - _ (&/when% must-compile? (compile-module ?path))] + _ (&/when% (not already-compiled?) (compile-module ?path))] (return (&/|list)))))) (defn analyse-export [analyse name] diff --git a/src/lux/base.clj b/src/lux/base.clj index 7b1e7139e..f88ca560e 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -33,9 +33,8 @@ (def $HOST 2) (def $MODULES 3) (def $SEED 4) -(def $SEEN-SOURCES 5) -(def $SOURCE 6) -(def $TYPES 7) +(def $SOURCE 5) +(def $TYPES 6) ;; [Exports] (def +name-separator+ ";") @@ -491,8 +490,6 @@ (|table) ;; "lux;seed" 0 - ;; "lux;seen-sources" - (|list) ;; "lux;source" (V "lux;None" nil) ;; "lux;types" @@ -711,15 +708,10 @@ (defn enumerate [xs] (enumerate* 0 xs)) -(defn source-seen? [path] - "(-> Text (Lux Bool))" - (fn [state] - (return* state (fold #(or %1 (= %2 path)) false (get$ $SEEN-SOURCES state))))) - -(defn see-source [path] - "(-> Text (Lux (,)))" +(def modules + "(Lux (List Text))" (fn [state] - (return* (update$ $SEEN-SOURCES (partial |cons path) state) nil))) + (return* state (|keys (get$ $MODULES state))))) (defn when% [test body] "(-> Bool (Lux (,)) (Lux (,)))" diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index fbf8afb89..9ecdcc6ad 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -369,7 +369,7 @@ return)))) (defn ^:private compile-module [name] - ;; (prn 'compile-module name) + (prn 'compile-module name (&&/cached? name)) (if (&&/cached? name) (do ;; (println "YOLO") (let [file-name (str "input/" name ".lux") diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 89303c48d..a9abe44fc 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -133,75 +133,77 @@ (defn load-cache [module module-hash compile-module] (|do [loader &/loader !classes &/classes - already-loaded? (&/source-seen? module) + already-loaded? (&a-module/exists? module) + _modules &/modules :let [redo-cache (|do [_ (delete-cache module) _ (compile-module module)] (return false))]] - (if already-loaded? - (return true) - (if (cached? module) - (do (prn 'load-cache module module-hash) - (let [module-path (str "cache/jvm/" (string/replace module #"/" " ")) - module* (string/replace module #"/" ".") - class-name (str module* "._") - ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) - (load-class! loader class-name))] - (if (and (= module-hash (get-field "_hash" module-meta)) - (= version (get-field "_compiler" module-meta))) - (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") - ;; _ (prn module 'imports imports) - ] - (|do [loads (&/map% (fn [_import] - (load-cache _import (-> (str "input/" _import ".lux") slurp hash) compile-module)) - (if (= [""] imports) - (&/|list) - (&/->list imports)))] - (if (->> loads &/->seq (every? true?)) - (do (doseq [^File file (seq (.listFiles (File. module-path))) - :let [file-name (.getName file)] - :when (not= "_.class" file-name)] - (let [real-name (second (re-find #"^(.*)\.class$" file-name)) - bytecode (read-file file) - ;; _ (prn 'load-cache module real-name) - ] - ;; (swap! !classes assoc (str module* "." (replace-cache real-name)) bytecode) - (swap! !classes assoc (str module* "." real-name) bytecode) - ;; (swap! !classes assoc "__temp__" bytecode) - ;; (swap! !classes assoc (-> (load-class! loader "__temp__") (.getField "_name") (.get nil)) bytecode) - (write-output module real-name bytecode))) - ;; (swap! !classes dissoc "__temp__") - (let [defs (string/split (get-field "_defs" module-meta) #"\t")] - ;; (prn 'load-cache module defs) - (|do [_ (&/see-source module) - _ (&a-module/enter-module module) - _ (&/map% (fn [_def] - (let [[_exported? _name _ann] (string/split _def #" ") - ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) - ] - (|do [_ (case _ann - "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) - "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] - (&a-module/declare-macro module _name)) - "V" (let [def-class (load-class! loader (str module* ".$" (&/normalize-ident _name))) - ;; _ (println "Fetching _meta" module _name (str module* ".$" (&/normalize-ident _name)) def-class) - def-type (get-field "_meta" def-class)] - (matchv ::M/objects [def-type] - [["lux;ValueD" _def-type]] - (&a-module/define module _name def-type _def-type))) - ;; else - (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] - (|do [__type (&a-module/def-type __module __name)] - (do ;; (prn '__type [__module __name] (&type/show-type __type)) - (&a-module/def-alias module _name __module __name __type)))))] - (if (= "1" _exported?) - (&a-module/export module _name) - (return nil))) - )) - (if (= [""] defs) - (&/|list) - (&/->list defs)))] - (return true)))) - redo-cache))) - redo-cache) - )) - redo-cache)))) + (do (prn 'load-cache module 'sources already-loaded? + (&/->seq _modules)) + (if already-loaded? + (return true) + (if (cached? module) + (do (prn 'load-cache/HASH module module-hash) + (let [module-path (str "cache/jvm/" (string/replace module #"/" " ")) + module* (string/replace module #"/" ".") + class-name (str module* "._") + ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (load-class! loader class-name))] + (if (and (= module-hash (get-field "_hash" module-meta)) + (= version (get-field "_compiler" module-meta))) + (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") + _ (prn 'load-cache/IMPORTS module imports) + ] + (|do [loads (&/map% (fn [_import] + (load-cache _import (-> (str "input/" _import ".lux") slurp hash) compile-module)) + (if (= [""] imports) + (&/|list) + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (do (doseq [^File file (seq (.listFiles (File. module-path))) + :let [file-name (.getName file)] + :when (not= "_.class" file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) + bytecode (read-file file) + ;; _ (prn 'load-cache module real-name) + ] + ;; (swap! !classes assoc (str module* "." (replace-cache real-name)) bytecode) + (swap! !classes assoc (str module* "." real-name) bytecode) + ;; (swap! !classes assoc "__temp__" bytecode) + ;; (swap! !classes assoc (-> (load-class! loader "__temp__") (.getField "_name") (.get nil)) bytecode) + (write-output module real-name bytecode))) + ;; (swap! !classes dissoc "__temp__") + (let [defs (string/split (get-field "_defs" module-meta) #"\t")] + ;; (prn 'load-cache module defs) + (|do [_ (&a-module/enter-module module) + _ (&/map% (fn [_def] + (let [[_exported? _name _ann] (string/split _def #" ") + ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) + ] + (|do [_ (case _ann + "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) + "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] + (&a-module/declare-macro module _name)) + "V" (let [def-class (load-class! loader (str module* ".$" (&/normalize-ident _name))) + ;; _ (println "Fetching _meta" module _name (str module* ".$" (&/normalize-ident _name)) def-class) + def-type (get-field "_meta" def-class)] + (matchv ::M/objects [def-type] + [["lux;ValueD" _def-type]] + (&a-module/define module _name def-type _def-type))) + ;; else + (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] + (|do [__type (&a-module/def-type __module __name)] + (do ;; (prn '__type [__module __name] (&type/show-type __type)) + (&a-module/def-alias module _name __module __name __type)))))] + (if (= "1" _exported?) + (&a-module/export module _name) + (return nil))) + )) + (if (= [""] defs) + (&/|list) + (&/->list defs)))] + (return true)))) + redo-cache))) + redo-cache) + )) + redo-cache))))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 77fc6a2f8..14e87e063 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -177,7 +177,6 @@ (&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type))) (&/T "lux;host" HostState) (&/T "lux;seed" Int) - (&/T "lux;seen-sources" (&/V "lux;AppT" (&/T List Text))) (&/T "lux;eval?" Bool)))) $Void))) -- cgit v1.2.3 From 6c51e5e50aa98bb26a3e2b34f57a0e24f8537d93 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 25 Jul 2015 18:02:26 -0400 Subject: /cache and /output now using same format. --- input/lux.lux | 48 ++++---------------- src/lux/analyser/module.clj | 14 ++---- src/lux/base.clj | 2 +- src/lux/compiler.clj | 108 ++++++++++++++++++++------------------------ src/lux/compiler/base.clj | 53 +++++----------------- src/lux/compiler/lambda.clj | 13 +++--- src/lux/compiler/lux.clj | 13 +++--- src/lux/host.clj | 11 +++-- src/lux/type.clj | 66 --------------------------- 9 files changed, 94 insertions(+), 234 deletions(-) diff --git a/input/lux.lux b/input/lux.lux index 3bd4d58d0..61d99396c 100644 --- a/input/lux.lux +++ b/input/lux.lux @@ -2187,14 +2187,9 @@ _ (;return (: (List Syntax) - (list:++ (map (lambda [m-name] - (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) [($ text:++ "lux;import " m-name "\n")]) - (` (_lux_import (~ (text$ m-name)))))) + (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) unknowns) - (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) ["\n"]) - (list (` (import (~@ tokens))))))))))) + (list (` (import (~@ tokens)))))))))) (def (some f xs) (All [a b] @@ -2388,13 +2383,6 @@ #;None (f x2) (#;Some y) (#;Some y))) -(def (try-both% x1 x2) - (All [a b] - (-> (Maybe a) (Maybe a) (Maybe a))) - (case x1 - #;None x2 - (#;Some _) x1)) - (def (find-in-env name state) (-> Ident Compiler (Maybe Type)) (let [vname' (ident->text name)] @@ -2406,30 +2394,14 @@ (lambda [env] (case env {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} - (try-both% (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#Some type) - #None)))) - locals) - (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#Some type) - #None)))) - closure)) - ## (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - ## (lambda [binding] - ## (let [[bname [_ type]] binding] - ## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - ## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-env #2: " bname "\n")]) - ## (if (text:= vname' bname) - ## (#Some type) - ## #None))))) - ## locals) - ))) + (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= vname' bname) + (#Some type) + #None))))) + locals + closure)))) envs)))) (def (show-envs envs) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 830319549..68cdc4747 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -77,10 +77,7 @@ [[_ ["lux;AliasD" [?r-module ?r-name]]]] (&/run-state (def-type ?r-module ?r-name) - state) - - [_] - (assert false (prn-str 'def-type (str module ";" name) (aget $def 0)))) + state)) (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) (fail* (str "[Analyser Error] Unknown module: " module))))) @@ -135,12 +132,7 @@ ;; (prn 'find-def/_0 module name 'current-module current-module) (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (try (->> $module (&/get$ $DEFS) (&/|get name)) - (catch StackOverflowError e - (assert false (prn-str 'find-def - (str module ";" name) - (&/->seq (&/|keys (&/get$ $DEFS $module))) - (&/->seq (&/|keys (&/get$ &/$MODULES state)))))))] + (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] (matchv ::M/objects [$def] [[exported? $$def]] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) @@ -170,7 +162,7 @@ [[exported? ["lux;ValueD" ?type]]] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (str (string/replace module #"/" ".") ".$" (&/normalize-ident name))) + :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) (.getField "_datum") (.get nil))]] (fn [state*] diff --git a/src/lux/base.clj b/src/lux/base.clj index f88ca560e..9f0a78fa7 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -427,7 +427,7 @@ ;; default char)) -(defn normalize-ident [ident] +(defn normalize-name [ident] (reduce str "" (map normalize-char ident))) (def loader diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 9ecdcc6ad..05ab12bf1 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -342,7 +342,7 @@ (&/with-eval (|do [module &/get-module-name id &/gen-id - :let [class-name (str module "/" id) + :let [class-name (str (&host/->module-class module) "/" id) ;; _ (prn 'eval! id class-name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) @@ -363,62 +363,58 @@ .visitEnd))] _ (&&/save-class! (str id) bytecode) loader &/loader] - (-> (.loadClass ^ClassLoader loader (str (string/replace module #"/" ".") "." id)) + (-> (.loadClass ^ClassLoader loader (str (&host/->module-class module) "." id)) (.getField "_eval") (.get nil) return)))) (defn ^:private compile-module [name] - (prn 'compile-module name (&&/cached? name)) - (if (&&/cached? name) - (do ;; (println "YOLO") - (let [file-name (str "input/" name ".lux") - file-content (slurp file-name)] - (&&/load-cache name (hash file-content) compile-module))) - (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] - (&/map% compile-statement analysis+))] - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (if (.equals ^Object name "lux") - (return nil) - (fail "[Compiler Error] Can't redefine a module!")) - (|do [_ (&a-module/enter-module name) - :let [file-name (str "input/" name ".lux") - file-content (slurp file-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str name "/_") nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil (hash file-content)) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) - .visitEnd))]] - (fn [state] - (matchv ::M/objects [((&/exhaust% compiler-step) - (->> state - (&/set$ &/$SOURCE (&reader/from file-name file-content)) - (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %))))] - [["lux;Right" [?state _]]] - (&/run-state (|do [defs &a-module/defs - imports &a-module/imports - :let [_ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil - (->> defs - (&/|map (fn [_def] - (|let [[?exported ?name ?ann] _def] - (str (if ?exported "1" "0") " " ?name " " ?ann)))) - (&/|interpose "\t") - (&/fold str ""))) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil - (->> imports (&/|interpose "\t") (&/fold str ""))) - .visitEnd) - (.visitEnd))]] - (&&/save-class! "_" (.toByteArray =class))) - ?state) - - [["lux;Left" ?message]] - (fail* ?message))))))) - )) + ;; (prn 'compile-module name (&&/cached? name)) + (let [file-name (str "input/" name ".lux") + file-content (slurp file-name) + file-hash (hash file-content)] + (if (&&/cached? name) + (&&/load-cache name file-hash compile-module) + (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] + (&/map% compile-statement analysis+))] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (fail "[Compiler Error] Can't redefine a module!") + (|do [_ (&a-module/enter-module name) + :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) + .visitEnd))]] + (fn [state] + (matchv ::M/objects [((&/exhaust% compiler-step) + (->> state + (&/set$ &/$SOURCE (&reader/from file-name file-content)) + (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %))))] + [["lux;Right" [?state _]]] + (&/run-state (|do [defs &a-module/defs + imports &a-module/imports + :let [_ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil + (->> defs + (&/|map (fn [_def] + (|let [[?exported ?name ?ann] _def] + (str (if ?exported "1" "0") " " ?name " " ?ann)))) + (&/|interpose "\t") + (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil + (->> imports (&/|interpose "\t") (&/fold str ""))) + .visitEnd) + (.visitEnd))]] + (&&/save-class! "_" (.toByteArray =class))) + ?state) + + [["lux;Left" ?message]] + (fail* ?message))))))) + ))) (defn ^:private clean-file [^java.io.File file] (if (.isDirectory file) @@ -440,14 +436,10 @@ (setup-dirs!) (matchv ::M/objects [((&/map% compile-module modules) (&/init-state nil))] [["lux;Right" [?state _]]] - (println (str "Compilation complete! " (str "[" (->> modules - (&/|interpose " ") - (&/fold str "")) - "]"))) + (println "Compilation complete!") [["lux;Left" ?message]] - (do (prn 'compile-all '?message ?message) - (assert false ?message)))) + (assert false ?message))) (comment (compile-all ["lux"]) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index a9abe44fc..d3dfc8746 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -12,7 +12,8 @@ [clojure.core.match :as M :refer [matchv]] clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail*]] - [type :as &type]) + [type :as &type] + [host :as &host]) (lux.analyser [base :as &a] [module :as &a-module])) (:import (org.objectweb.asm Opcodes @@ -30,12 +31,12 @@ (.write stream data))) (defn ^:private write-output [module name data] - (let [module* module] + (let [module* (&host/->module-class module)] (.mkdirs (File. (str "output/jvm/" module*))) (write-file (str "output/jvm/" module* "/" name ".class") data))) (defn ^:private write-cache [module name data] - (let [module* (string/replace module #"/" " ")] + (let [module* (&host/->module-class module)] (.mkdirs (File. (str "cache/jvm/" module*))) (write-file (str "cache/jvm/" module* "/" name ".class") data))) @@ -70,7 +71,7 @@ module &/get-module-name loader &/loader !classes &/classes - :let [real-name (str (string/replace module #"/" ".") "." name) + :let [real-name (str (&host/->module-class module) "." name) _ (swap! !classes assoc real-name bytecode) _ (load-class! loader real-name) _ (when (not eval?) @@ -79,11 +80,11 @@ (return nil))) (defn cached? [module] - (.exists (File. (str "cache/jvm/" (string/replace module #"/" " ") "/_.class")))) + (.exists (File. (str "cache/jvm/" (&host/->module-class module) "/_.class")))) (defn delete-cache [module] (fn [state] - (do (clean-file (File. (str "cache/jvm/" (string/replace module #"/" " ")))) + (do (clean-file (File. (str "cache/jvm/" (&host/->module-class module)))) (return* state nil)))) (defn ^:private replace-several [content & replacements] @@ -95,34 +96,6 @@ (throw e))) content replacement-list))) -(defn ^:private replace-cache [^String cache-name] - (if (.startsWith cache-name "$") - (replace-several cache-name - #"_ASTER_" "*" - #"_PLUS_" "+" - #"_DASH_" "-" - #"_SLASH_" "/" - #"_BSLASH_" "\\" - #"_UNDERS_" "_" - #"_PERCENT_" "%" - #"_DOLLAR_" "$" - #"_QUOTE_" "'" - #"_BQUOTE_" "`" - #"_AT_" "@" - #"_CARET_" "^" - #"_AMPERS_" "&" - #"_EQ_" "=" - #"_BANG_" "!" - #"_QM_" "?" - #"_COLON_" ":" - #"_PERIOD_" "." - #"_COMMA_" "," - #"_LT_" "<" - #"_GT_" ">" - #"_TILDE_" "~" - #"_PIPE_" "|") - cache-name)) - (defn ^:private get-field [^String field-name ^Class class] (-> class ^Field (.getField field-name) (.get nil)) ;; (try (-> class ^Field (.getField field-name) (.get nil)) @@ -144,8 +117,8 @@ (return true) (if (cached? module) (do (prn 'load-cache/HASH module module-hash) - (let [module-path (str "cache/jvm/" (string/replace module #"/" " ")) - module* (string/replace module #"/" ".") + (let [module* (&host/->module-class module) + module-path (str "cache/jvm/" module*) class-name (str module* "._") ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) (load-class! loader class-name))] @@ -167,12 +140,8 @@ bytecode (read-file file) ;; _ (prn 'load-cache module real-name) ] - ;; (swap! !classes assoc (str module* "." (replace-cache real-name)) bytecode) (swap! !classes assoc (str module* "." real-name) bytecode) - ;; (swap! !classes assoc "__temp__" bytecode) - ;; (swap! !classes assoc (-> (load-class! loader "__temp__") (.getField "_name") (.get nil)) bytecode) (write-output module real-name bytecode))) - ;; (swap! !classes dissoc "__temp__") (let [defs (string/split (get-field "_defs" module-meta) #"\t")] ;; (prn 'load-cache module defs) (|do [_ (&a-module/enter-module module) @@ -184,8 +153,8 @@ "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] (&a-module/declare-macro module _name)) - "V" (let [def-class (load-class! loader (str module* ".$" (&/normalize-ident _name))) - ;; _ (println "Fetching _meta" module _name (str module* ".$" (&/normalize-ident _name)) def-class) + "V" (let [def-class (load-class! loader (str module* "." (&/normalize-name _name))) + ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) def-type (get-field "_meta" def-class)] (matchv ::M/objects [def-type] [["lux;ValueD" _def-type]] diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 9f4bef80c..d97cc1f26 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -93,20 +93,21 @@ ;; [Exports] (defn compile-lambda [compile ?scope ?env ?body] ;; (prn 'compile-lambda (->> ?scope &/->seq)) - (|do [:let [lambda-class (str (&/|head ?scope) "/$" (&host/location (&/|tail ?scope))) + (|do [:let [name (&host/location (&/|tail ?scope)) + class-name (str (&host/->module-class (&/|head ?scope)) "/" name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - lambda-class nil "java/lang/Object" (into-array ["lux/Function"])) + class-name nil "java/lang/Object" (into-array ["lux/Function"])) (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (matchv ::M/objects [?name+?captured] [[?name [["captured" [_ ?captured-id ?source]] _]]]) (doseq [?name+?captured (&/->seq ?env)]))) - (add-lambda-apply lambda-class ?env) - (add-lambda- lambda-class ?env) + (add-lambda-apply class-name ?env) + (add-lambda- class-name ?env) )] _ (add-lambda-impl =class compile lambda-impl-signature ?body) :let [_ (.visitEnd =class)] - _ (&&/save-class! (str "$" (&host/location (&/|tail ?scope))) (.toByteArray =class))] - (instance-closure compile lambda-class ?env (lambda--signature ?env)))) + _ (&&/save-class! name (.toByteArray =class))] + (instance-closure compile class-name ?env (lambda--signature ?env)))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 66db6923d..32a7af751 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -115,14 +115,14 @@ :let [_ (doto *writer* (.visitVarInsn Opcodes/ALOAD 0) (.visitFieldInsn Opcodes/GETFIELD - (str (&/|head ?scope) "/$" (&host/location (&/|tail ?scope))) + (str (&host/->module-class (&/|head ?scope)) "/" (&host/location (&/|tail ?scope))) (str &&/closure-prefix ?captured-id) "Ljava/lang/Object;"))]] (return nil))) (defn compile-global [compile *type* ?owner-class ?name] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str ?owner-class "/$" (&/normalize-ident ?name)) "_datum" "Ljava/lang/Object;")]] + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) "_datum" "Ljava/lang/Object;")]] (return nil))) (defn compile-apply [compile *type* ?fn ?args] @@ -279,10 +279,9 @@ (defn compile-def [compile ?name ?body ?def-data] (|do [^ClassWriter *writer* &/get-writer module-name &/get-module-name - :let [outer-class (&host/->class module-name) - datum-sig "Ljava/lang/Object;" - current-class (str outer-class "/" (str "$" (&/normalize-ident ?name))) - ;; _ (prn 'compile-def 'outer-class outer-class '?name ?name 'current-class current-class) + :let [datum-sig "Ljava/lang/Object;" + def-name (&/normalize-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) current-class nil "java/lang/Object" (into-array ["lux/Function"])) @@ -305,7 +304,7 @@ (.visitEnd))]] (return nil))) :let [_ (.visitEnd *writer*)] - _ (&&/save-class! (str "$" (&/normalize-ident ?name)) (.toByteArray =class))] + _ (&&/save-class! def-name (.toByteArray =class))] (return nil))) (defn compile-ann [compile *type* ?value-ex ?type-ex] diff --git a/src/lux/host.clj b/src/lux/host.clj index abbdb8c6d..d248c708e 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -39,7 +39,10 @@ (defn ^String ->class [class] (string/replace class #"\." "/")) -(def ->package ->class) +(defn ^String ->module-class [module-name] + (string/replace module-name #"/" " ")) + +(def ->package ->module-class) (defn ->type-signature [class] ;; (assert (string? class)) @@ -70,9 +73,7 @@ [["lux;VariantT" ["lux;Nil" _]]] "V" - - [_] - (assert false (prn-str '->java-sig (aget type 0))))) + )) (defn extract-jvm-param [token] (matchv ::M/objects [token] @@ -114,4 +115,4 @@ ) (defn location [scope] - (->> scope (&/|map &/normalize-ident) (&/|interpose "$") (&/fold str ""))) + (->> scope (&/|map &/normalize-name) (&/|interpose "$") (&/fold str ""))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 14e87e063..f1a5b7623 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -416,73 +416,7 @@ [args body*]))] (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) ?name) - - [_] - (assert false (prn-str 'show-type (aget type 0) (class (aget type 1)))) )) -;; (defn show-type [^objects type] -;; (matchv ::M/objects [type] -;; [["lux;DataT" name]] -;; (str "(^ " name ")") - -;; [["lux;TupleT" elems]] -;; (if (&/|empty? elems) -;; "(,)" -;; (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - -;; [["lux;VariantT" cases]] -;; (if (&/|empty? cases) -;; "(|)" -;; (str "(| " (->> cases -;; (&/|map (fn [kv] -;; (matchv ::M/objects [kv] -;; [[k ["lux;TupleT" ["lux;Nil" _]]]] -;; (str "#" k) - -;; [[k v]] -;; (str "(#" k " " (show-type v) ")")))) -;; (&/|interpose " ") -;; (&/fold str "")) ")")) - - -;; [["lux;RecordT" fields]] -;; (str "(& " (->> fields -;; (&/|map (fn [kv] -;; (matchv ::M/objects [kv] -;; [[k v]] -;; (str "#" k " " (show-type v))))) -;; (&/|interpose " ") -;; (&/fold str "")) ")") - -;; [["lux;LambdaT" [input output]]] -;; (str "(-> " (show-type input) " " (show-type output) ")") - -;; [["lux;VarT" id]] -;; (str "⌈" id "⌋") - -;; [["lux;BoundT" name]] -;; name - -;; [["lux;ExT" ?id]] -;; (str "⟨" ?id "⟩") - -;; [["lux;AppT" [?lambda ?param]]] -;; (str "(" (show-type ?lambda) " " (show-type ?param) ")") - -;; [["lux;AllT" [?env ?name ?arg ?body]]] -;; (let [[args body] (loop [args (list ?arg) -;; body* ?body] -;; (matchv ::M/objects [body*] -;; [["lux;AllT" [?env* ?name* ?arg* ?body*]]] -;; (recur (cons ?arg* args) ?body*) - -;; [_] -;; [args body*]))] -;; (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) - -;; [_] -;; (assert false (prn-str 'show-type (aget type 0) (class (aget type 1)))) -;; )) (defn type= [x y] (or (clojure.lang.Util/identical x y) -- cgit v1.2.3 From 4cd9b0c9242f1105e50ad9b42b7f6f5d074f14b4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 25 Jul 2015 20:19:43 -0400 Subject: - The output directory is now being used as the cache. - "input" has been renamed as "source" and "output" has been renamed as "target". --- input/lux.lux | 2784 ---------------------------------------- input/lux/codata/stream.lux | 133 -- input/lux/control/comonad.lux | 54 - input/lux/control/functor.lux | 15 - input/lux/control/lazy.lux | 47 - input/lux/control/monad.lux | 99 -- input/lux/control/monoid.lux | 24 - input/lux/data/bool.lux | 33 - input/lux/data/bounded.lux | 17 - input/lux/data/char.lux | 20 - input/lux/data/dict.lux | 83 -- input/lux/data/either.lux | 46 - input/lux/data/eq.lux | 14 - input/lux/data/error.lux | 34 - input/lux/data/id.lux | 28 - input/lux/data/io.lux | 51 - input/lux/data/list.lux | 250 ---- input/lux/data/maybe.lux | 42 - input/lux/data/number.lux | 119 -- input/lux/data/ord.lux | 44 - input/lux/data/reader.lux | 33 - input/lux/data/show.lux | 14 - input/lux/data/state.lux | 35 - input/lux/data/text.lux | 146 --- input/lux/data/writer.lux | 34 - input/lux/host/java.lux | 312 ----- input/lux/math.lux | 60 - input/lux/meta/lux.lux | 287 ----- input/lux/meta/macro.lux | 54 - input/lux/meta/syntax.lux | 262 ---- input/program.lux | 48 - source/lux.lux | 2784 ++++++++++++++++++++++++++++++++++++++++ source/lux/codata/stream.lux | 133 ++ source/lux/control/comonad.lux | 54 + source/lux/control/functor.lux | 15 + source/lux/control/lazy.lux | 47 + source/lux/control/monad.lux | 99 ++ source/lux/control/monoid.lux | 24 + source/lux/data/bool.lux | 33 + source/lux/data/bounded.lux | 17 + source/lux/data/char.lux | 20 + source/lux/data/dict.lux | 83 ++ source/lux/data/either.lux | 46 + source/lux/data/eq.lux | 14 + source/lux/data/error.lux | 34 + source/lux/data/id.lux | 28 + source/lux/data/io.lux | 51 + source/lux/data/list.lux | 250 ++++ source/lux/data/maybe.lux | 42 + source/lux/data/number.lux | 119 ++ source/lux/data/ord.lux | 44 + source/lux/data/reader.lux | 33 + source/lux/data/show.lux | 14 + source/lux/data/state.lux | 35 + source/lux/data/text.lux | 146 +++ source/lux/data/writer.lux | 34 + source/lux/host/java.lux | 312 +++++ source/lux/math.lux | 60 + source/lux/meta/lux.lux | 287 +++++ source/lux/meta/macro.lux | 54 + source/lux/meta/syntax.lux | 262 ++++ source/program.lux | 48 + src/lux.clj | 4 +- src/lux/analyser/host.clj | 6 +- src/lux/analyser/lux.clj | 2 +- src/lux/compiler.clj | 34 +- src/lux/compiler/base.clj | 144 +-- src/lux/compiler/cache.clj | 135 ++ 68 files changed, 5387 insertions(+), 5382 deletions(-) delete mode 100644 input/lux.lux delete mode 100644 input/lux/codata/stream.lux delete mode 100644 input/lux/control/comonad.lux delete mode 100644 input/lux/control/functor.lux delete mode 100644 input/lux/control/lazy.lux delete mode 100644 input/lux/control/monad.lux delete mode 100644 input/lux/control/monoid.lux delete mode 100644 input/lux/data/bool.lux delete mode 100644 input/lux/data/bounded.lux delete mode 100644 input/lux/data/char.lux delete mode 100644 input/lux/data/dict.lux delete mode 100644 input/lux/data/either.lux delete mode 100644 input/lux/data/eq.lux delete mode 100644 input/lux/data/error.lux delete mode 100644 input/lux/data/id.lux delete mode 100644 input/lux/data/io.lux delete mode 100644 input/lux/data/list.lux delete mode 100644 input/lux/data/maybe.lux delete mode 100644 input/lux/data/number.lux delete mode 100644 input/lux/data/ord.lux delete mode 100644 input/lux/data/reader.lux delete mode 100644 input/lux/data/show.lux delete mode 100644 input/lux/data/state.lux delete mode 100644 input/lux/data/text.lux delete mode 100644 input/lux/data/writer.lux delete mode 100644 input/lux/host/java.lux delete mode 100644 input/lux/math.lux delete mode 100644 input/lux/meta/lux.lux delete mode 100644 input/lux/meta/macro.lux delete mode 100644 input/lux/meta/syntax.lux delete mode 100644 input/program.lux create mode 100644 source/lux.lux create mode 100644 source/lux/codata/stream.lux create mode 100644 source/lux/control/comonad.lux create mode 100644 source/lux/control/functor.lux create mode 100644 source/lux/control/lazy.lux create mode 100644 source/lux/control/monad.lux create mode 100644 source/lux/control/monoid.lux create mode 100644 source/lux/data/bool.lux create mode 100644 source/lux/data/bounded.lux create mode 100644 source/lux/data/char.lux create mode 100644 source/lux/data/dict.lux create mode 100644 source/lux/data/either.lux create mode 100644 source/lux/data/eq.lux create mode 100644 source/lux/data/error.lux create mode 100644 source/lux/data/id.lux create mode 100644 source/lux/data/io.lux create mode 100644 source/lux/data/list.lux create mode 100644 source/lux/data/maybe.lux create mode 100644 source/lux/data/number.lux create mode 100644 source/lux/data/ord.lux create mode 100644 source/lux/data/reader.lux create mode 100644 source/lux/data/show.lux create mode 100644 source/lux/data/state.lux create mode 100644 source/lux/data/text.lux create mode 100644 source/lux/data/writer.lux create mode 100644 source/lux/host/java.lux create mode 100644 source/lux/math.lux create mode 100644 source/lux/meta/lux.lux create mode 100644 source/lux/meta/macro.lux create mode 100644 source/lux/meta/syntax.lux create mode 100644 source/program.lux create mode 100644 src/lux/compiler/cache.clj diff --git a/input/lux.lux b/input/lux.lux deleted file mode 100644 index 61d99396c..000000000 --- a/input/lux.lux +++ /dev/null @@ -1,2784 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -## First things first, must define functions -(_jvm_interface "Function" [] - (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) - -## Basic types -(_lux_def Bool (#DataT "java.lang.Boolean")) -(_lux_export Bool) - -(_lux_def Int (#DataT "java.lang.Long")) -(_lux_export Int) - -(_lux_def Real (#DataT "java.lang.Double")) -(_lux_export Real) - -(_lux_def Char (#DataT "java.lang.Character")) -(_lux_export Char) - -(_lux_def Text (#DataT "java.lang.String")) -(_lux_export Text) - -(_lux_def Unit (#TupleT #Nil)) -(_lux_export Unit) - -(_lux_def Void (#VariantT #Nil)) -(_lux_export Void) - -(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) -(_lux_export Ident) - -## (deftype (List a) -## (| #Nil -## (#Cons (, a (List a))))) -(_lux_def List - (#AllT [(#Some #Nil) "lux;List" "a" - (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] - (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) - #Nil])]))] - #Nil])]))])) -(_lux_export List) - -## (deftype (Maybe a) -## (| #None -## (#Some a))) -(_lux_def Maybe - (#AllT [(#Some #Nil) "lux;Maybe" "a" - (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] - (#Cons [["lux;Some" (#BoundT "a")] - #Nil])]))])) -(_lux_export Maybe) - -## (deftype #rec Type -## (| (#DataT Text) -## (#TupleT (List Type)) -## (#VariantT (List (, Text Type))) -## (#RecordT (List (, Text Type))) -## (#LambdaT (, Type Type)) -## (#BoundT Text) -## (#VarT Int) -## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) -## (#AppT (, Type Type)))) -(_lux_def Type - (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) - Type - (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) - TypeEnv - (#AppT [(#AllT [(#Some #Nil) "Type" "_" - (#VariantT (#Cons [["lux;DataT" Text] - (#Cons [["lux;TupleT" (#AppT [List Type])] - (#Cons [["lux;VariantT" TypeEnv] - (#Cons [["lux;RecordT" TypeEnv] - (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;BoundT" Text] - (#Cons [["lux;VarT" Int] - (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] - (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;ExT" Int] - #Nil])])])])])])])])])]))]) - Void])))) -(_lux_export Type) - -## (deftype (Bindings k v) -## (& #counter Int -## #mappings (List (, k v)))) -(_lux_def Bindings - (#AllT [(#Some #Nil) "lux;Bindings" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;counter" Int] - (#Cons [["lux;mappings" (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))])] - #Nil])]))])])) -(_lux_export Bindings) - -## (deftype (Env k v) -## (& #name Text -## #inner-closures Int -## #locals (Bindings k v) -## #closure (Bindings k v))) -(_lux_def Env - (#AllT [(#Some #Nil) "lux;Env" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;name" Text] - (#Cons [["lux;inner-closures" Int] - (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - #Nil])])])]))])])) -(_lux_export Env) - -## (deftype Cursor -## (, Text Int Int)) -(_lux_def Cursor - (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) -(_lux_export Cursor) - -## (deftype (Meta m v) -## (| (#Meta (, m v)))) -(_lux_def Meta - (#AllT [(#Some #Nil) "lux;Meta" "m" - (#AllT [#None "" "v" - (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") - (#Cons [(#BoundT "v") - #Nil])]))] - #Nil]))])])) -(_lux_export Meta) - -## (deftype (Syntax' w) -## (| (#BoolS Bool) -## (#IntS Int) -## (#RealS Real) -## (#CharS Char) -## (#TextS Text) -## (#SymbolS (, Text Text)) -## (#TagS (, Text Text)) -## (#FormS (List (w (Syntax' w)))) -## (#TupleS (List (w (Syntax' w)))) -## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) -(_lux_def Syntax' - (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "lux;Syntax'") - (#BoundT "w")])]) - Syntax - (_lux_case (#AppT [List Syntax]) - SyntaxList - (#AllT [(#Some #Nil) "lux;Syntax'" "w" - (#VariantT (#Cons [["lux;BoolS" Bool] - (#Cons [["lux;IntS" Int] - (#Cons [["lux;RealS" Real] - (#Cons [["lux;CharS" Char] - (#Cons [["lux;TextS" Text] - (#Cons [["lux;SymbolS" Ident] - (#Cons [["lux;TagS" Ident] - (#Cons [["lux;FormS" SyntaxList] - (#Cons [["lux;TupleS" SyntaxList] - (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] - #Nil]) - ])])])])])])])])]) - )])))) -(_lux_export Syntax') - -## (deftype Syntax -## (Meta Cursor (Syntax' (Meta Cursor)))) -(_lux_def Syntax - (_lux_case (#AppT [Meta Cursor]) - w - (#AppT [w (#AppT [Syntax' w])]))) -(_lux_export Syntax) - -(_lux_def SyntaxList (#AppT [List Syntax])) - -## (deftype (Either l r) -## (| (#Left l) -## (#Right r))) -(_lux_def Either - (#AllT [(#Some #Nil) "lux;Either" "l" - (#AllT [#None "" "r" - (#VariantT (#Cons [["lux;Left" (#BoundT "l")] - (#Cons [["lux;Right" (#BoundT "r")] - #Nil])]))])])) -(_lux_export Either) - -## (deftype (StateE s a) -## (-> s (Either Text (, s a)))) -(_lux_def StateE - (#AllT [(#Some #Nil) "lux;StateE" "s" - (#AllT [#None "" "a" - (#LambdaT [(#BoundT "s") - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [(#BoundT "s") - (#Cons [(#BoundT "a") - #Nil])]))])])])])) - -## (deftype Reader -## (List (Meta Cursor Text))) -(_lux_def Reader - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])])) -(_lux_export Reader) - -## (deftype HostState -## (& #writer (^ org.objectweb.asm.ClassWriter) -## #loader (^ java.net.URLClassLoader) -## #classes (^ clojure.lang.Atom))) -(_lux_def HostState - (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] - (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] - #Nil])])]))) - -## (deftype (DefData' m) -## (| #TypeD -## (#ValueD Type) -## (#MacroD m) -## (#AliasD Ident))) -(_lux_def DefData' - (#AllT [(#Some #Nil) "lux;DefData'" "" - (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] - (#Cons [["lux;ValueD" Type] - (#Cons [["lux;MacroD" (#BoundT "")] - (#Cons [["lux;AliasD" Ident] - #Nil])])])]))])) -(_lux_export DefData') - -## (deftype LuxVar -## (| (#Local Int) -## (#Global Ident))) -(_lux_def LuxVar - (#VariantT (#Cons [["lux;Local" Int] - (#Cons [["lux;Global" Ident] - #Nil])]))) -(_lux_export LuxVar) - -## (deftype (Module Compiler) -## (& #module-aliases (List (, Text Text)) -## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) -## #imports (List Text) -## )) -(_lux_def Module - (#AllT [(#Some #Nil) "lux;Module" "Compiler" - (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] - (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - SyntaxList])])]) - #Nil])])) - #Nil])]))])] - (#Cons [["lux;imports" (#AppT [List Text])] - #Nil])])]))])) -(_lux_export Module) - -## (deftype #rec Compiler -## (& #source Reader -## #modules (List (, Text (Module Compiler))) -## #envs (List (Env Text (, LuxVar Type))) -## #types (Bindings Int Type) -## #host HostState -## #seed Int -## #eval? Bool)) -(_lux_def Compiler - (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" - (#RecordT (#Cons [["lux;source" Reader] - (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) - #Nil])]))])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - (#Cons [["lux;seed" Int] - (#Cons [["lux;eval?" Bool] - #Nil])])])])])])]))]) - Void])) -(_lux_export Compiler) - -## (deftype Macro -## (-> (List Syntax) (StateE Compiler (List Syntax)))) -(_lux_def Macro - (#LambdaT [SyntaxList - (#AppT [(#AppT [StateE Compiler]) - SyntaxList])])) -(_lux_export Macro) - -## Base functions & macros -## (def _cursor -## Cursor -## ["" -1 -1]) -(_lux_def _cursor - (_lux_: Cursor ["" -1 -1])) - -## (def (_meta data) -## (-> (Syntax' (Meta Cursor)) Syntax) -## (#Meta [["" -1 -1] data])) -(_lux_def _meta - (_lux_: (#LambdaT [(#AppT [Syntax' - (#AppT [Meta Cursor])]) - Syntax]) - (_lux_lambda _ data - (#Meta [_cursor data])))) - -## (def (return x) -## (All [a] -## (-> a Compiler -## (Either Text (, Compiler a)))) -## ...) -(_lux_def return - (_lux_: (#AllT [(#Some #Nil) "" "a" - (#LambdaT [(#BoundT "a") - (#LambdaT [Compiler - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [Compiler - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (_lux_lambda _ val - (_lux_lambda _ state - (#Right [state val]))))) - -## (def (fail msg) -## (All [a] -## (-> Text Compiler -## (Either Text (, Compiler a)))) -## ...) -(_lux_def fail - (_lux_: (#AllT [(#Some #Nil) "" "a" - (#LambdaT [Text - (#LambdaT [Compiler - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [Compiler - (#Cons [(#BoundT "a") - #Nil])]))])])])]) - (_lux_lambda _ msg - (_lux_lambda _ state - (#Left msg))))) - -(_lux_def text$ - (_lux_: (#LambdaT [Text Syntax]) - (_lux_lambda _ text - (_meta (#TextS text))))) - -(_lux_def symbol$ - (_lux_: (#LambdaT [Ident Syntax]) - (_lux_lambda _ ident - (_meta (#SymbolS ident))))) - -(_lux_def tag$ - (_lux_: (#LambdaT [Ident Syntax]) - (_lux_lambda _ ident - (_meta (#TagS ident))))) - -(_lux_def form$ - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) - (_lux_lambda _ tokens - (_meta (#FormS tokens))))) - -(_lux_def tuple$ - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) - (_lux_lambda _ tokens - (_meta (#TupleS tokens))))) - -(_lux_def record$ - (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) - (_lux_lambda _ tokens - (_meta (#RecordS tokens))))) - -(_lux_def let' - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_case"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil])) - - _ - (fail "Wrong syntax for let'"))))) -(_lux_declare-macro let') - -(_lux_def lambda' - (_lux_: Macro - (_lux_lambda _ tokens - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS ["" ""])) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS self)) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - _ - (fail "Wrong syntax for lambda"))))) -(_lux_declare-macro lambda') - -(_lux_def def' - (_lux_: Macro - (lambda' [tokens] - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil])) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil])) - - _ - (fail "Wrong syntax for def") - )))) -(_lux_declare-macro def') - -(def' (defmacro tokens) - Macro - (_lux_case tokens - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) - (#Cons [(form$ (#Cons [name args])) - (#Cons [(symbol$ ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])) - (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])])) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) - (#Cons [(tag$ ["" "export"]) - (#Cons [(form$ (#Cons [name args])) - (#Cons [(symbol$ ["lux" "Macro"]) - (#Cons [body - #Nil])]) - ])])])) - (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) - #Nil])])) - - _ - (fail "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) - -(defmacro #export (comment tokens) - (return #Nil)) - -(defmacro (->' tokens) - (_lux_case tokens - (#Cons [input (#Cons [output #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil])) - - (#Cons [input (#Cons [output others])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for ->'"))) - -(defmacro (All' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS #Nil)]) - (#Cons [body #Nil])]) - (return (#Cons [body - #Nil])) - - (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) - (#Cons [body #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) - (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) - (#Cons [(_meta (#TextS "")) - (#Cons [(_meta (#TextS arg-name)) - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) - (#Cons [(_meta (#TupleS other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for All'"))) - -(defmacro (B' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) - #Nil]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) - (#Cons [(_meta (#TextS bound-name)) - #Nil])]))) - #Nil])) - - _ - (fail "Wrong syntax for B'"))) - -(defmacro ($' tokens) - (_lux_case tokens - (#Cons [x #Nil]) - (return tokens) - - (#Cons [x (#Cons [y xs])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) - (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil])) - - _ - (fail "Wrong syntax for $'"))) - -(def' (foldL f init xs) - (All' [a b] - (->' (->' (B' a) (B' b) (B' a)) - (B' a) - ($' List (B' b)) - (B' a))) - (_lux_case xs - #Nil - init - - (#Cons [x xs']) - (foldL f (f init x) xs'))) - -(def' (reverse list) - (All' [a] - (->' ($' List (B' a)) ($' List (B' a)))) - (foldL (lambda' [tail head] (#Cons [head tail])) - #Nil - list)) - -(defmacro (list xs) - (return (#Cons [(foldL (lambda' [tail head] - (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) - (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) - (_meta (#TagS ["lux" "Nil"])) - (reverse xs)) - #Nil]))) - -(defmacro (list& xs) - (_lux_case (reverse xs) - (#Cons [last init]) - (return (list (foldL (lambda' [tail head] - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list head tail))))))) - last - init))) - - _ - (fail "Wrong syntax for list&"))) - -(defmacro #export (lambda tokens) - (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) - [name tokens'] - - _ - [["" ""] tokens])) - (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case args - #Nil - (fail "lambda requires a non-empty arguments tuple.") - - (#Cons [harg targs]) - (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) - (symbol$ name) - harg - (foldL (lambda' [body' arg] - (form$ (list (symbol$ ["" "_lux_lambda"]) - (symbol$ ["" ""]) - arg - body'))) - body - (reverse targs))))))) - - _ - (fail "Wrong syntax for lambda")))) - -(defmacro (def'' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) - type - (form$ (list (symbol$ ["lux" "lambda"]) - name - (tuple$ args) - body)))))) - (form$ (list (symbol$ ["" "_lux_export"]) name)))) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) - type - body)))) - (form$ (list (symbol$ ["" "_lux_export"]) name)))) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) - type - (form$ (list (symbol$ ["lux" "lambda"]) - name - (tuple$ args) - body)))))))) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) type body)))))) - - _ - (fail "Wrong syntax for def") - )) - -(def'' (as-pairs xs) - (All' [a] - (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) - (_lux_case xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) - - _ - #Nil)) - -(defmacro #export (let tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) - (return (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) - (lambda [body binding] - (_lux_case binding - [label value] - (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) - body - (reverse (as-pairs bindings))))) - - _ - (fail "Wrong syntax for let"))) - -(def'' (map f xs) - (All' [a b] - (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) - (_lux_case xs - #Nil - #Nil - - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) - -(def'' (any? p xs) - (All' [a] - (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) - (_lux_case xs - #Nil - false - - (#Cons [x xs']) - (_lux_case (p x) - true true - false (any? p xs')))) - -(def'' (spliced? token) - (->' Syntax Bool) - (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) - true - - _ - false)) - -(def'' (wrap-meta content) - (->' Syntax Syntax) - (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) - (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) - content))))))) - -(def'' (untemplate-list tokens) - (->' ($' List Syntax) Syntax) - (_lux_case tokens - #Nil - (_meta (#TagS ["lux" "Nil"])) - - (#Cons [token tokens']) - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list token (untemplate-list tokens'))))))))) - -(def'' #export (list:++ xs ys) - (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) - (_lux_case xs - (#Cons [x xs']) - (#Cons [x (list:++ xs' ys)]) - - #Nil - ys)) - -(defmacro #export ($ tokens) - (_lux_case tokens - (#Cons [op (#Cons [init args])]) - (return (list (foldL (lambda [a1 a2] (form$ (list op a1 a2))) - init - args))) - - _ - (fail "Wrong syntax for $"))) - -(def'' (splice replace? untemplate tag elems) - (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) - (_lux_case replace? - true - (_lux_case (any? spliced? elems) - true - (let [elems' (map (lambda [elem] - (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced - - _ - (form$ (list (symbol$ ["" "_lux_:"]) - (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) - (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) - (tag$ ["lux" "Nil"]))))))))) - elems)] - (wrap-meta (form$ (list tag - (form$ (list& (symbol$ ["lux" "$"]) - (symbol$ ["lux" "list:++"]) - elems')))))) - - false - (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))) - false - (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) - -(def'' (untemplate replace? subst token) - (->' Bool Text Syntax Syntax) - (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token]) - [_ (#Meta [_ (#BoolS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) - - [_ (#Meta [_ (#IntS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) - - [_ (#Meta [_ (#RealS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) - - [_ (#Meta [_ (#CharS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) - - [_ (#Meta [_ (#TextS value)])] - (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) - - [_ (#Meta [_ (#TagS [module name])])] - (let [module' (_lux_case module - "" - subst - - _ - module)] - (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) - - [_ (#Meta [_ (#SymbolS [module name])])] - (let [module' (_lux_case module - "" - subst - - _ - module)] - (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) - - [_ (#Meta [_ (#TupleS elems)])] - (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - - [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] - unquoted - - [_ (#Meta [_ (#FormS elems)])] - (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) - - [_ (#Meta [_ (#RecordS fields)])] - (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) - (lambda [kv] - (let [[k v] kv] - (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) - fields))))) - )) - -(defmacro (`' tokens) - (_lux_case tokens - (#Cons [template #Nil]) - (return (list (untemplate true "" template))) - - _ - (fail "Wrong syntax for `'"))) - -(defmacro (' tokens) - (_lux_case tokens - (#Cons [template #Nil]) - (return (list (untemplate false "" template))) - - _ - (fail "Wrong syntax for '"))) - -(defmacro #export (|> tokens) - (_lux_case tokens - (#Cons [init apps]) - (return (list (foldL (lambda [acc app] - (_lux_case app - (#Meta [_ (#TupleS parts)]) - (tuple$ (list:++ parts (list acc))) - - (#Meta [_ (#FormS parts)]) - (form$ (list:++ parts (list acc))) - - _ - (`' ((~ app) (~ acc))))) - init - apps))) - - _ - (fail "Wrong syntax for |>"))) - -(defmacro #export (if tokens) - (_lux_case tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (list (`' (_lux_case (~ test) - true (~ then) - false (~ else))))) - - _ - (fail "Wrong syntax for if"))) - -## (deftype (Lux a) -## (-> Compiler (Either Text (, Compiler a)))) -(def'' #export Lux - Type - (All' [a] - (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) - -## (defsig (Monad m) -## (: (All [a] (-> a (m a))) -## return) -## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) -## bind)) -(def'' Monad - Type - (All' [m] - (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] - ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b))))])))) - -(def'' Maybe/Monad - ($' Monad Maybe) - {#lux;return - (lambda return [x] - (#Some x)) - - #lux;bind - (lambda [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) - -(def'' Lux/Monad - ($' Monad Lux) - {#lux;return - (lambda [x] - (lambda [state] - (#Right [state x]))) - - #lux;bind - (lambda [f ma] - (lambda [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) - - (#Right [state' a]) - (f a state'))))}) - -(defmacro #export (^ tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) - (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) - - _ - (fail "Wrong syntax for ^"))) - -(defmacro #export (-> tokens) - (_lux_case (reverse tokens) - (#Cons [output inputs]) - (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) - output - inputs))) - - _ - (fail "Wrong syntax for ->"))) - -(defmacro #export (, tokens) - (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) - -(defmacro (do tokens) - (_lux_case tokens - (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) - (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (_lux_case var - (#Meta [_ (#TagS ["" "let"])]) - (`' (;let (~ value) (~ body'))) - - _ - (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) - (~ var) - (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (return (list (`' (_lux_case (~ monad) - {#;return ;return #;bind ;bind} - (~ body')))))) - - _ - (fail "Wrong syntax for do"))) - -(def'' (map% m f xs) - ## (All [m a b] - ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) - (All' [m a b] - (-> ($' Monad (B' m)) - (-> (B' a) ($' (B' m) (B' b))) - ($' List (B' a)) - ($' (B' m) ($' List (B' b))))) - (let [{#;return ;return #;bind _} m] - (_lux_case xs - #Nil - (;return #Nil) - - (#Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;return (#Cons [y ys]))) - ))) - -(def'' #export (. f g) - (All' [a b c] - (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) - (lambda [x] - (f (g x)))) - -(def'' (get-ident x) - (-> Syntax ($' Maybe Text)) - (_lux_case x - (#Meta [_ (#SymbolS ["" sname])]) - (#Some sname) - - _ - #None)) - -(def'' (tuple->list tuple) - (-> Syntax ($' Maybe ($' List Syntax))) - (_lux_case tuple - (#Meta [_ (#TupleS members)]) - (#Some members) - - _ - #None)) - -(def'' RepEnv - Type - ($' List (, Text Syntax))) - -(def'' (make-env xs ys) - (-> ($' List Text) ($' List Syntax) RepEnv) - (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) - [xs ys]) - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (make-env xs' ys')]) - - _ - #Nil)) - -(def'' #export (text:= x y) - (-> Text Text Bool) - (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] - x [y])) - -(def'' (get-rep key env) - (-> Text RepEnv ($' Maybe Syntax)) - (_lux_case env - #Nil - #None - - (#Cons [[k v] env']) - (if (text:= k key) - (#Some v) - (get-rep key env')))) - -(def'' (apply-template env template) - (-> RepEnv Syntax Syntax) - (_lux_case template - (#Meta [_ (#SymbolS ["" sname])]) - (_lux_case (get-rep sname env) - (#Some subst) - subst - - _ - template) - - (#Meta [_ (#TupleS elems)]) - (tuple$ (map (apply-template env) elems)) - - (#Meta [_ (#FormS elems)]) - (form$ (map (apply-template env) elems)) - - (#Meta [_ (#RecordS members)]) - (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [kv] - (let [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) - members)) - - _ - template)) - -(def'' (join-map f xs) - (All' [a b] - (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) - (_lux_case xs - #Nil - #Nil - - (#Cons [x xs']) - (list:++ (f x) (join-map f xs')))) - -(defmacro #export (do-template tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) - (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(map% Maybe/Monad get-ident bindings) - (map% Maybe/Monad tuple->list data)]) - [(#Some bindings') (#Some data')] - (let [apply (_lux_: (-> RepEnv ($' List Syntax)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - return)) - - _ - (fail "Wrong syntax for do-template")) - - _ - (fail "Wrong syntax for do-template"))) - -(do-template [ ] - [(def'' #export ( x y) - (-> Bool) - ( x y))] - - [i= _jvm_leq Int] - [i> _jvm_lgt Int] - [i< _jvm_llt Int] - [r= _jvm_deq Real] - [r> _jvm_dgt Real] - [r< _jvm_dlt Real] - ) - -(do-template [ ] - [(def'' #export ( x y) - (-> Bool) - (if ( x y) - true - ( x y)))] - - [i>= i> i= Int] - [i<= i< i= Int] - [r>= r> r= Real] - [r<= r< r= Real] - ) - -(do-template [ ] - [(def'' #export ( x y) - (-> ) - ( x y))] - - [i+ _jvm_ladd Int] - [i- _jvm_lsub Int] - [i* _jvm_lmul Int] - [i/ _jvm_ldiv Int] - [i% _jvm_lrem Int] - [r+ _jvm_dadd Real] - [r- _jvm_dsub Real] - [r* _jvm_dmul Real] - [r/ _jvm_ddiv Real] - [r% _jvm_drem Real] - ) - -(def'' (multiple? div n) - (-> Int Int Bool) - (i= 0 (i% n div))) - -(def'' (length list) - (-> List Int) - (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) - -(def'' #export (not x) - (-> Bool Bool) - (if x false true)) - -(def'' #export (text:++ x y) - (-> Text Text Text) - (_jvm_invokevirtual java.lang.String concat [java.lang.String] - x [y])) - -(def'' (ident->text ident) - (-> Ident Text) - (let [[module name] ident] - ($ text:++ module ";" name))) - -(def'' (replace-syntax reps syntax) - (-> RepEnv Syntax Syntax) - (_lux_case syntax - (#Meta [_ (#SymbolS ["" name])]) - (_lux_case (get-rep name reps) - (#Some replacement) - replacement - - #None - syntax) - - (#Meta [_ (#FormS parts)]) - (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) - - (#Meta [_ (#TupleS members)]) - (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - - (#Meta [_ (#RecordS slots)]) - (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))]) - - _ - syntax) - ) - -(defmacro #export (All tokens) - (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) - [self-ident tokens'] - - _ - ["" tokens]))] - (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe/Monad get-ident args) - (#Some idents) - (_lux_case idents - #Nil - (return (list body)) - - (#Cons [harg targs]) - (let [replacements (map (_lux_: (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) - (list& self-ident idents)) - body' (foldL (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) - (replace-syntax replacements body) - (reverse targs))] - ## (#;Some #;Nil) - (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) - - #None - (fail "'All' arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) - )) - -(def'' (get k plist) - (All [a] - (-> Text ($' List (, Text a)) ($' Maybe a))) - (_lux_case plist - (#Cons [[k' v] plist']) - (if (text:= k k') - (#Some v) - (get k plist')) - - #Nil - #None)) - -(def'' (put k v dict) - (All [a] - (-> Text a ($' List (, Text a)) ($' List (, Text a)))) - (_lux_case dict - #Nil - (list [k v]) - - (#Cons [[k' v'] dict']) - (if (text:= k k') - (#Cons [[k' v] dict']) - (#Cons [[k' v'] (put k v dict')])))) - -(def'' (get-module-name state) - ($' Lux Text) - (_lux_case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (_lux_case (reverse envs) - #Nil - (#Left "Can't get the module name without a module!") - - (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) - (#Right [state module-name])))) - -(def'' (find-macro' modules current-module module name) - (-> ($' List (, Text ($' Module Compiler))) - Text Text Text - ($' Maybe Macro)) - (do Maybe/Monad - [$module (get module modules) - gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] - (get name bindings))] - (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) - [exported? (#MacroD macro')] - (if exported? - (#Some macro') - (if (text:= module current-module) - (#Some macro') - #None)) - - [_ (#AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) - - _ - #None))) - -(def'' (find-macro ident) - (-> Ident ($' Lux ($' Maybe Macro))) - (do Lux/Monad - [current-module get-module-name] - (let [[module name] ident] - (lambda [state] - (_lux_case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (#Right [state (find-macro' modules current-module module name)])))))) - -(def'' (list:join xs) - (All [a] - (-> ($' List ($' List a)) ($' List a))) - (foldL list:++ #Nil xs)) - -(def'' (normalize ident) - (-> Ident ($' Lux Ident)) - (_lux_case ident - ["" name] - (do Lux/Monad - [module-name get-module-name] - (;return (_lux_: Ident [module-name name]))) - - _ - (return ident))) - -(defmacro #export (| tokens) - (do Lux/Monad - [pairs (map% Lux/Monad - (_lux_: (-> Syntax ($' Lux Syntax)) - (lambda [token] - (_lux_case token - (#Meta [_ (#TagS ident)]) - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) - - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for |")))) - tokens)] - (;return (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) - -(defmacro #export (& tokens) - (if (not (multiple? 2 (length tokens))) - (fail "& expects an even number of arguments.") - (do Lux/Monad - [pairs (map% Lux/Monad - (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) - (lambda [pair] - (_lux_case pair - [(#Meta [_ (#TagS ident)]) value] - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for &")))) - (as-pairs tokens))] - (;return (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) - -(def'' #export (->text x) - (-> (^ java.lang.Object) Text) - (_jvm_invokevirtual java.lang.Object toString [] x [])) - -(def'' (interpose sep xs) - (All [a] - (-> a ($' List a) ($' List a))) - (_lux_case xs - #Nil - xs - - (#Cons [x #Nil]) - xs - - (#Cons [x xs']) - (list& x sep (interpose sep xs')))) - -(def'' (macro-expand syntax) - (-> Syntax ($' Lux ($' List Syntax))) - (_lux_case syntax - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) - (do Lux/Monad - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (_lux_case ?macro - (#Some macro) - (do Lux/Monad - [expansion (macro args) - expansion' (map% Lux/Monad macro-expand expansion)] - (;return (list:join expansion'))) - - #None - (do Lux/Monad - [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] - (;return (list (form$ (list:join parts'))))))) - - (#Meta [_ (#FormS (#Cons [harg targs]))]) - (do Lux/Monad - [harg+ (macro-expand harg) - targs+ (map% Lux/Monad macro-expand targs)] - (;return (list (form$ (list:++ harg+ (list:join targs+)))))) - - (#Meta [_ (#TupleS members)]) - (do Lux/Monad - [members' (map% Lux/Monad macro-expand members)] - (;return (list (tuple$ (list:join members'))))) - - _ - (return (list syntax)))) - -(def'' (walk-type type) - (-> Syntax Syntax) - (_lux_case type - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) - (form$ (#Cons [(tag$ tag) (map walk-type parts)])) - - (#Meta [_ (#TupleS members)]) - (tuple$ (map walk-type members)) - - (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) - (walk-type type-fn) - (map walk-type args)) - - _ - type)) - -(defmacro #export (type tokens) - (_lux_case tokens - (#Cons [type #Nil]) - (do Lux/Monad - [type+ (macro-expand type)] - (_lux_case type+ - (#Cons [type' #Nil]) - (;return (list (walk-type type'))) - - _ - (fail "The expansion of the type-syntax had to yield a single element."))) - - _ - (fail "Wrong syntax for type"))) - -(defmacro #export (: tokens) - (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (_lux_: (;type (~ type)) (~ value))))) - - _ - (fail "Wrong syntax for :"))) - -(defmacro #export (:! tokens) - (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) - (return (list (`' (_lux_:! (;type (~ type)) (~ value))))) - - _ - (fail "Wrong syntax for :!"))) - -(def'' (empty? xs) - (All [a] (-> ($' List a) Bool)) - (_lux_case xs - #Nil true - _ false)) - -(defmacro #export (deftype tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] - - _ - [false tokens])) - [rec? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) - [true tokens'] - - _ - [false tokens'])) - parts (: (Maybe (, Text (List Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) - (#Some [name #Nil type]) - - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) - (#Some [name args type]) - - _ - #None))] - (_lux_case parts - (#Some [name args type]) - (let [with-export (: (List Syntax) - (if export? - (list (`' (_lux_export (~ (symbol$ ["" name]))))) - #Nil)) - type' (: (Maybe Syntax) - (if rec? - (if (empty? args) - (let [g!param (symbol$ ["" ""]) - prime-name (symbol$ ["" (text:++ name "'")]) - type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] - (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) - ;Void)))) - #None) - (_lux_case args - #Nil - (#Some type) - - _ - (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] - (_lux_case type' - (#Some type'') - (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) - with-export)) - - #None - (fail "Wrong syntax for deftype"))) - - #None - (fail "Wrong syntax for deftype")) - )) -## (defmacro #export (deftype tokens) -## (let [[export? tokens'] (: (, Bool (List Syntax)) -## (_lux_case (:! (List Syntax) tokens) -## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) -## [true (:! (List Syntax) tokens')] - -## _ -## [false (:! (List Syntax) tokens)])) -## parts (: (Maybe (, Syntax (List Syntax) Syntax)) -## (_lux_case tokens' -## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) -## (#Some [(symbol$ name) #Nil type]) - -## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) -## (#Some [(symbol$ name) args type]) - -## _ -## #None))] -## (_lux_case parts -## (#Some [name args type]) -## (let [with-export (: (List Syntax) -## (if export? -## (list (`' (_lux_export (~ name)))) -## #Nil)) -## type' (: Syntax -## (_lux_case args -## #Nil -## type - -## _ -## (`' (;All (~ name) [(~@ args)] (~ type)))))] -## (return (list& (`' (_lux_def (~ name) (;type (~ type')))) -## with-export))) - -## #None -## (fail "Wrong syntax for deftype")) -## )) - -(defmacro #export (exec tokens) - (_lux_case (reverse tokens) - (#Cons [value actions]) - (let [dummy (symbol$ ["" ""])] - (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) - value - actions)))) - - _ - (fail "Wrong syntax for exec"))) - -(defmacro #export (def tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] - - _ - [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (#Some [name args (#Some type) body]) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (#Some [name #Nil (#Some type) body]) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) - - (#Cons [name (#Cons [body #Nil])]) - (#Some [name #Nil #None body]) - - _ - #None))] - (_lux_case parts - (#Some [name args ?type body]) - (let [body' (: Syntax - (_lux_case args - #Nil - body - - _ - (`' (;lambda (~ name) [(~@ args)] (~ body))))) - body'' (: Syntax - (_lux_case ?type - (#Some type) - (`' (: (~ type) (~ body'))) - - #None - body'))] - (return (list& (`' (_lux_def (~ name) (~ body''))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for def")))) - -(def (rejoin-pair pair) - (-> (, Syntax Syntax) (List Syntax)) - (let [[left right] pair] - (list left right))) - -(defmacro #export (case tokens) - (_lux_case tokens - (#Cons [value branches]) - (do Lux/Monad - [expansions (map% Lux/Monad - (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) - (lambda expander [branch] - (let [[pattern body] branch] - (_lux_case pattern - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) - (do Lux/Monad - [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) - expansions (map% Lux/Monad expander (as-pairs expansion))] - (;return (list:join expansions))) - - _ - (;return (list branch)))))) - (as-pairs branches))] - (;return (list (`' (_lux_case (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) - - _ - (fail "Wrong syntax for case"))) - -(defmacro #export (\ tokens) - (case tokens - (#Cons [body (#Cons [pattern #Nil])]) - (do Lux/Monad - [pattern+ (macro-expand pattern)] - (case pattern+ - (#Cons [pattern' #Nil]) - (;return (list pattern' body)) - - _ - (fail "\\ can only expand to 1 pattern."))) - - _ - (fail "Wrong syntax for \\"))) - -(defmacro #export (\or tokens) - (case tokens - (#Cons [body patterns]) - (case patterns - #Nil - (fail "\\or can't have 0 patterns") - - _ - (do Lux/Monad - [patterns' (map% Lux/Monad macro-expand patterns)] - (;return (list:join (map (lambda [pattern] (list pattern body)) - (list:join patterns')))))) - - _ - (fail "Wrong syntax for \\or"))) - -(do-template [ ] - [(def #export (i+ ))] - - [inc 1] - [dec -1]) - -(defmacro #export (` tokens) - (do Lux/Monad - [module-name get-module-name] - (case tokens - (\ (list template)) - (;return (list (untemplate true module-name template))) - - _ - (fail "Wrong syntax for `")))) - -(def (gensym prefix state) - (-> Text (Lux Syntax)) - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (#Right [{#source source #modules modules - #envs envs #types types #host host - #seed (inc seed) #eval? eval?} - (symbol$ ["__gensym__" (->text seed)])]))) - -(def (macro-expand-1 token) - (-> Syntax (Lux Syntax)) - (do Lux/Monad - [token+ (macro-expand token)] - (case token+ - (\ (list token')) - (;return token') - - _ - (fail "Macro expanded to more than 1 element.")))) - -(defmacro #export (sig tokens) - (do Lux/Monad - [tokens' (map% Lux/Monad macro-expand tokens) - members (map% Lux/Monad - (: (-> Syntax (Lux (, Ident Syntax))) - (lambda [token] - (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) - (do Lux/Monad - [name' (normalize name)] - (;return (: (, Ident Syntax) [name' type]))) - - _ - (fail "Signatures require typed members!")))) - (list:join tokens'))] - (;return (list (`' (#;RecordT (~ (untemplate-list (map (: (-> (, Ident Syntax) Syntax) - (lambda [pair] - (let [[name type] pair] - (`' [(~ (|> name ident->text text$)) - (~ type)])))) - members))))))))) - -(defmacro #export (defsig tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) - [true tokens'] - - _ - [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) - (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) - (#Some [name args sigs]) - - (\ (list& name sigs)) - (#Some [name #Nil sigs]) - - _ - #None))] - (case ?parts - (#Some [name args sigs]) - (let [sigs' (: Syntax - (case args - #Nil - (`' (;sig (~@ sigs))) - - _ - (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (list& (`' (_lux_def (~ name) (~ sigs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for defsig")))) - -(defmacro #export (struct tokens) - (do Lux/Monad - [tokens' (map% Lux/Monad macro-expand tokens) - members (map% Lux/Monad - (: (-> Syntax (Lux (, Syntax Syntax))) - (lambda [token] - (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) - (do Lux/Monad - [name' (normalize name)] - (;return (: (, Syntax Syntax) [(tag$ name') value]))) - - _ - (fail "Structures require defined members!")))) - (list:join tokens'))] - (;return (list (record$ members))))) - -(defmacro #export (defstruct tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) - [true tokens'] - - _ - [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) - (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) - (#Some [name args type defs]) - - (\ (list& name type defs)) - (#Some [name #Nil type defs]) - - _ - #None))] - (case ?parts - (#Some [name args type defs]) - (let [defs' (: Syntax - (case args - #Nil - (`' (;struct (~@ defs))) - - _ - (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (list& (`' (def (~ name) (~ type) (~ defs'))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for defstruct")))) - -(def #export (id x) - (All [a] (-> a a)) - x) - -(do-template [ ] - [(defmacro #export ( tokens) - (case (reverse tokens) - (\ (list& last init)) - (return (list (foldL (lambda [post pre] (` )) - last - init))) - - _ - (fail )))] - - [and (if (~ pre) (~ post) false) "and requires >=1 clauses."] - [or (if (~ pre) true (~ post)) "or requires >=1 clauses."]) - -(deftype Referrals - (| #All - (#Only (List Text)) - (#Except (List Text)) - #Nothing)) - -(deftype Import - (, Text (Maybe Text) Referrals)) - -(def (extract-defs defs) - (-> (List Syntax) (Lux (List Text))) - (map% Lux/Monad - (: (-> Syntax (Lux Text)) - (lambda [def] - (case def - (#Meta [_ (#SymbolS ["" name])]) - (return name) - - _ - (fail "only/except requires symbols.")))) - defs)) - -(def (parse-alias tokens) - (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax)))) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens')) - (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens'])) - - _ - (return (: (, (Maybe Text) (List Syntax)) [#None tokens])))) - -(def (parse-referrals tokens) - (-> (List Syntax) (Lux (, Referrals (List Syntax)))) - (case tokens - (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens')) - (case referral - (#Meta [_ (#TagS ["" "all"])]) - (return (: (, Referrals (List Syntax)) [#All tokens'])) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))])) - (do Lux/Monad - [defs' (extract-defs defs)] - (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "except"])]) defs))])) - (do Lux/Monad - [defs' (extract-defs defs)] - (return (: (, Referrals (List Syntax)) [(#Except defs') tokens']))) - - _ - (fail "Incorrect syntax for referral.")) - - _ - (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) - -(def (decorate-imports super-name tokens) - (-> Text (List Syntax) (Lux (List Syntax))) - (map% Lux/Monad - (: (-> Syntax (Lux Syntax)) - (lambda [token] - (case token - (#Meta [_ (#SymbolS ["" sub-name])]) - (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))])) - (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) - - _ - (fail "Wrong import syntax.")))) - tokens)) - -(def (parse-imports imports) - (-> (List Syntax) (Lux (List Import))) - (do Lux/Monad - [referrals' (map% Lux/Monad - (: (-> Syntax (Lux (List Import))) - (lambda [token] - (case token - (#Meta [_ (#SymbolS ["" m-name])]) - (;return (list [m-name #None #All])) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) - (do Lux/Monad - [alias+extra' (parse-alias extra) - #let [[alias extra'] (: (, (Maybe Text) (List Syntax)) - alias+extra')] - referral+extra'' (parse-referrals extra') - #let [[referral extra''] (: (, Referrals (List Syntax)) - referral+extra'')] - extra''' (decorate-imports m-name extra'') - sub-imports (parse-imports extra''')] - (;return (case referral - #Nothing (case alias - #None sub-imports - (#Some _) (list& [m-name alias referral] sub-imports)) - _ (list& [m-name alias referral] sub-imports)))) - - _ - (fail "Wrong syntax for import")))) - imports)] - (;return (list:join referrals')))) - -(def (module-exists? module state) - (-> Text (Lux Bool)) - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (case (get module modules) - (#Some =module) - (#Right [state true]) - - #None - (#Right [state false])) - )) - -(def (exported-defs module state) - (-> Text (Lux (List Text))) - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (case (get module modules) - (#Some =module) - (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (list name) - (list))))) - (let [{#module-aliases _ #defs defs #imports _} =module] - defs))] - (#Right [state (list:join to-alias)])) - - #None - (#Left ($ text:++ "Unknown module: " module))) - )) - -(def (last-index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String lastIndexOf [java.lang.String] - text [part]))) - -(def (index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String] - text [part]))) - -(def (substring1 idx text) - (-> Int Text Text) - (_jvm_invokevirtual java.lang.String substring [int] - text [(_jvm_l2i idx)])) - -(def (substring2 idx1 idx2 text) - (-> Int Int Text Text) - (_jvm_invokevirtual java.lang.String substring [int int] - text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) - -(def (split-module-contexts module) - (-> Text (List Text)) - (#Cons [module (let [idx (last-index-of "/" module)] - (if (i< idx 0) - #Nil - (split-module-contexts (substring2 0 idx module))))])) - -(def (split-module module) - (-> Text (List Text)) - (let [idx (index-of "/" module)] - (if (i< idx 0) - (#Cons [module #Nil]) - (#Cons [(substring2 0 idx module) - (split-module (substring1 (inc idx) module))])))) - -(def (@ idx xs) - (All [a] - (-> Int (List a) (Maybe a))) - (case xs - #Nil - #None - - (#Cons [x xs']) - (if (i= idx 0) - (#Some x) - (@ (dec idx) xs') - ))) - -(def (split-with' p ys xs) - (All [a] - (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) - (case xs - #Nil - [ys xs] - - (#Cons [x xs']) - (if (p x) - (split-with' p (list& x ys) xs') - [ys xs]))) - -(def (split-with p xs) - (All [a] - (-> (-> a Bool) (List a) (, (List a) (List a)))) - (let [[ys' xs'] (split-with' p #Nil xs)] - [(reverse ys') xs'])) - -(def (clean-module module) - (-> Text (Lux Text)) - (do Lux/Monad - [module-name get-module-name] - (case (split-module module) - (\ (list& "." parts)) - (return (|> (list& module-name parts) (interpose "/") (foldL text:++ ""))) - - parts - (let [[ups parts'] (split-with (text:= "..") parts) - num-ups (length ups)] - (if (i= num-ups 0) - (return module) - (case (@ num-ups (split-module-contexts module-name)) - #None - (fail (text:++ "Can't clean module: " module)) - - (#Some top-module) - (return (|> (list& top-module parts') (interpose "/") (foldL text:++ "")))) - ))) - )) - -(def (filter p xs) - (All [a] (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - (list) - - (#;Cons [x xs']) - (if (p x) - (#;Cons [x (filter p xs')]) - (filter p xs')))) - -(def (is-member? cases name) - (-> (List Text) Text Bool) - (let [output (foldL (lambda [prev case] - (or prev - (text:= case name))) - false - cases)] - output)) - -(defmacro #export (import tokens) - (do Lux/Monad - [imports (parse-imports tokens) - imports (map% Lux/Monad - (: (-> Import (Lux Import)) - (lambda [import] - (case import - [m-name m-alias m-referrals] - (do Lux/Monad - [m-name (clean-module m-name)] - (;return (: Import [m-name m-alias m-referrals])))))) - imports) - unknowns' (map% Lux/Monad - (: (-> Import (Lux (List Text))) - (lambda [import] - (case import - [m-name _ _] - (do Lux/Monad - [? (module-exists? m-name)] - (;return (if ? - (list) - (list m-name))))))) - imports) - #let [unknowns (list:join unknowns')]] - (case unknowns - #Nil - (do Lux/Monad - [output' (map% Lux/Monad - (: (-> Import (Lux (List Syntax))) - (lambda [import] - (case import - [m-name m-alias m-referrals] - (do Lux/Monad - [defs (case m-referrals - #All - (exported-defs m-name) - - (#Only +defs) - (do Lux/Monad - [*defs (exported-defs m-name)] - (;return (filter (is-member? +defs) *defs))) - - (#Except -defs) - (do Lux/Monad - [*defs (exported-defs m-name)] - (;return (filter (. not (is-member? -defs)) *defs))) - - #Nothing - (;return (list)))] - (;return ($ list:++ - (list (` (_lux_import (~ (text$ m-name))))) - (case m-alias - #None (list) - (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) - (map (: (-> Text Syntax) - (lambda [def] - (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) - defs))))))) - imports)] - (;return (list:join output'))) - - _ - (;return (: (List Syntax) - (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) - unknowns) - (list (` (import (~@ tokens)))))))))) - -(def (some f xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #Nil - #None - - (#Cons [x xs']) - (case (f x) - #None - (some f xs') - - (#Some y) - (#Some y)))) - -(def (split-slot slot) - (-> Text (, Text Text)) - (let [idx (index-of ";" slot) - module (substring2 0 idx slot) - name (substring1 (inc idx) slot)] - [module name])) - -(def (type:show type) - (-> Type Text) - (case type - (#DataT name) - ($ text:++ "(^ " name ")") - - (#TupleT elems) - (case elems - #;Nil - "(,)" - - _ - ($ text:++ "(, " (|> elems (map type:show) (interpose " ") (foldL text:++ "")) ")")) - - (#VariantT cases) - (case cases - #;Nil - "(|)" - - _ - ($ text:++ "(| " - (|> cases - (map (: (-> (, Text Type) Text) - (lambda [kv] - (case kv - [k (#TupleT #;Nil)] - ($ text:++ "#" k) - - [k v] - ($ text:++ "(#" k " " (type:show v) ")"))))) - (interpose " ") - (foldL text:++ "")) - ")")) - - (#RecordT fields) - (case fields - #;Nil - "(&)" - - _ - ($ text:++ "(& " - (|> fields - (map (: (-> (, Text Type) Text) - (: (-> (, Text Type) Text) - (lambda [kv] - (let [[k v] kv] - ($ text:++ "(#" k " " (type:show v) ")")))))) - (interpose " ") - (foldL text:++ "")) - ")")) - - (#LambdaT [input output]) - ($ text:++ "(-> " (type:show input) " " (type:show output) ")") - - (#VarT id) - ($ text:++ "⌈" (->text id) "⌋") - - (#BoundT name) - name - - (#ExT ?id) - ($ text:++ "⟨" (->text ?id) "⟩") - - (#AppT [?lambda ?param]) - ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")") - - (#AllT [?env ?name ?arg ?body]) - ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")") - )) - -(def (beta-reduce env type) - (-> (List (, Text Type)) Type Type) - (case type - (#VariantT ?cases) - (#VariantT (map (: (-> (, Text Type) (, Text Type)) - (lambda [kv] - (let [[k v] kv] - [k (beta-reduce env v)]))) - ?cases)) - - (#RecordT ?fields) - (#RecordT (map (: (-> (, Text Type) (, Text Type)) - (lambda [kv] - (let [[k v] kv] - [k (beta-reduce env v)]))) - ?fields)) - - (#TupleT ?members) - (#TupleT (map (beta-reduce env) ?members)) - - (#AppT [?type-fn ?type-arg]) - (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)]) - - (#AllT [?local-env ?local-name ?local-arg ?local-def]) - (case ?local-env - #None - (#AllT [(#Some env) ?local-name ?local-arg ?local-def]) - - (#Some _) - type) - - (#LambdaT [?input ?output]) - (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)]) - - (#BoundT ?name) - (case (get ?name env) - (#Some bound) - bound - - _ - type) - - _ - type - )) - -(defmacro #export (? tokens) - (case tokens - (\ (list maybe else)) - (do Lux/Monad - [g!value (gensym "")] - (return (list (` (case (~ maybe) - (#;Some (~ g!value)) - (~ g!value) - - _ - (~ else)))))) - - _ - (fail "Wrong syntax for ?"))) - -(def (apply-type type-fn param) - (-> Type Type (Maybe Type)) - (case type-fn - (#AllT [env name arg body]) - (#Some (beta-reduce (|> (? env (list)) - (put name type-fn) - (put arg param)) - body)) - - (#AppT [F A]) - (do Maybe/Monad - [type-fn* (apply-type F A)] - (apply-type type-fn* param)) - - _ - #None)) - -(def (resolve-struct-type type) - (-> Type (Maybe Type)) - (case type - (#RecordT slots) - (#Some type) - - (#AppT [fun arg]) - (apply-type fun arg) - - (#AllT [_ _ _ body]) - (resolve-struct-type body) - - _ - #None)) - -(def (try-both f x1 x2) - (All [a b] - (-> (-> a (Maybe b)) a a (Maybe b))) - (case (f x1) - #;None (f x2) - (#;Some y) (#;Some y))) - -(def (find-in-env name state) - (-> Ident Compiler (Maybe Type)) - (let [vname' (ident->text name)] - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} - (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#Some type) - #None))))) - locals - closure)))) - envs)))) - -(def (show-envs envs) - (-> (List (Env Text (, LuxVar Type))) Text) - (|> envs - (map (lambda [env] - (case env - {#name name #inner-closures _ #locals {#counter _ #mappings locals} #closure _} - ($ text:++ name ": " (|> locals - (map (: (All [a] (-> (, Text a) Text)) - (lambda [b] (let [[label _] b] label)))) - (interpose " ") - (foldL text:++ "")))))) - (interpose "\n") - (foldL text:++ ""))) - -(def (find-in-defs name state) - (-> Ident Compiler (Maybe Type)) - (let [[v-prefix v-name] name - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} state] - (case (get v-prefix modules) - #None - #None - - (#Some {#defs defs #module-aliases _ #imports _}) - (case (get v-name defs) - #None - #None - - (#Some [_ def-data]) - (case def-data - #TypeD (#Some Type) - (#ValueD type) (#Some type) - (#MacroD m) (#Some Macro) - (#AliasD name') (find-in-defs name' state)))))) -## (def (find-in-defs name state) -## (-> Ident Compiler (Maybe Type)) -## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] -## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-defs #1: " (ident->text name) "\n")]) -## (let [[v-prefix v-name] name -## {#source source #modules modules -## #envs envs #types types #host host -## #seed seed #eval? eval?} state] -## (do Maybe/Monad -## [module (get v-prefix modules) -## #let [{#defs defs #module-aliases _ #imports _} module] -## def (get v-name defs) -## #let [[_ def-data] def]] -## (case def-data -## #TypeD (;return Type) -## (#ValueD type) (;return type) -## (#MacroD m) (;return Macro) -## (#AliasD name') (find-in-defs name' state)))))) - -(def (find-var-type name) - (-> Ident (Lux Type)) - (do Lux/Monad - [name' (normalize name)] - (lambda [state] - (case (find-in-env name state) - (#Some struct-type) - (#Right [state struct-type]) - - _ - (case (find-in-defs name' state) - (#Some struct-type) - (#Right [state struct-type]) - - _ - (let [{#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} state] - (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) - -(defmacro #export (using tokens) - (case tokens - (\ (list struct body)) - (case struct - (#Meta [_ (#SymbolS name)]) - (do Lux/Monad - [struct-type (find-var-type name)] - (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) - (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) - (lambda [slot] - (let [[sname stype] slot - full-name (split-slot sname)] - [(tag$ full-name) (symbol$ full-name)]))) - slots))] - (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) - - _ - (fail "Can only \"use\" records."))) - - _ - (let [dummy (symbol$ ["" ""])] - (return (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) - (~ body)))))))) - - _ - (fail "Wrong syntax for using"))) - -(def #export (flip f) - (All [a b c] - (-> (-> a b c) (-> b a c))) - (lambda [y x] - (f x y))) - -(def #export (curry f) - (All [a b c] - (-> (-> (, a b) c) - (-> a b c))) - (lambda [x y] - (f [x y]))) - -(def #export (uncurry f) - (All [a b c] - (-> (-> a b c) - (-> (, a b) c))) - (lambda [xy] - (let [[x y] xy] - (f x y)))) - -(defmacro #export (cond tokens) - (if (i= 0 (i% (length tokens) 2)) - (fail "cond requires an even number of arguments.") - (case (reverse tokens) - (\ (list& else branches')) - (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [else branch] - (let [[right left] branch] - (` (if (~ left) (~ right) (~ else)))))) - else - (as-pairs branches')))) - - _ - (fail "Wrong syntax for cond")))) - -(defmacro #export (get@ tokens) - (case tokens - (\ (list (#Meta [_ (#TagS slot')]) record)) - (case record - (#Meta [_ (#SymbolS name)]) - (do Lux/Monad - [type (find-var-type name) - g!blank (gensym "") - g!output (gensym "")] - (case (resolve-struct-type type) - (#Some (#RecordT slots)) - (do Lux/Monad - [slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-type] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - g!output - g!blank)]))) - slots))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output))))))) - - _ - (fail "get@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (get@ (~ (tag$ slot')) (~ _record)))))))) - - _ - (fail "Wrong syntax for get@"))) - -(defmacro #export (open tokens) - (case tokens - (\ (list (#Meta [_ (#SymbolS struct-name)]))) - (do Lux/Monad - [struct-type (find-var-type struct-name)] - (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) - (return (map (: (-> (, Text Type) Syntax) - (lambda [slot] - (let [[sname stype] slot - [module name] (split-slot sname)] - (` (_lux_def (~ (symbol$ ["" name])) - (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name)))))))) - slots)) - - _ - (fail "Can only \"open\" records."))) - - _ - (fail "Wrong syntax for open"))) - -(def (foldL% M f x ys) - (All [m a b] - (-> (Monad m) (-> a b (m a)) a (List b) - (m a))) - (case ys - (#Cons [y ys']) - (do M - [x' (f x y)] - (foldL% M f x' ys')) - - #Nil - ((get@ #return M) x))) - -(defmacro #export (:: tokens) - (case tokens - (\ (list& start parts)) - (do Lux/Monad - [output (foldL% Lux/Monad - (: (-> Syntax Syntax (Lux Syntax)) - (lambda [so-far part] - (case part - (#Meta [_ (#SymbolS slot)]) - (return (` (get@ (~ (tag$ slot)) (~ so-far)))) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))])) - (return (` ((get@ (~ (tag$ slot)) (~ so-far)) - (~@ args)))) - - _ - (fail "Wrong syntax for ::")))) - start parts)] - (return (list output))) - - _ - (fail "Wrong syntax for ::"))) - -(defmacro #export (set@ tokens) - (case tokens - (\ (list (#Meta [_ (#TagS slot')]) value record)) - (case record - (#Meta [_ (#SymbolS name)]) - (do Lux/Monad - [type (find-var-type name)] - (case (resolve-struct-type type) - (#Some (#RecordT slots)) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text Syntax))) - (lambda [slot] - (let [[r-slot-name r-type] slot] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name g!slot]))))) - slots) - slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-var] slot] - [(tag$ (split-slot r-slot-name)) r-var]))) - pattern')) - output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-var] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - value - r-var)]))) - pattern'))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) - - _ - (fail "set@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (set@ (~ (tag$ slot')) (~ value) (~ _record)))))))) - - _ - (fail "Wrong syntax for set@"))) - -(defmacro #export (update@ tokens) - (case tokens - (\ (list (#Meta [_ (#TagS slot')]) fun record)) - (case record - (#Meta [_ (#SymbolS name)]) - (do Lux/Monad - [type (find-var-type name)] - (case (resolve-struct-type type) - (#Some (#RecordT slots)) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text Syntax))) - (lambda [slot] - (let [[r-slot-name r-type] slot] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name g!slot]))))) - slots) - slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-var] slot] - [(tag$ (split-slot r-slot-name)) r-var]))) - pattern')) - output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[r-slot-name r-var] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - (` ((~ fun) (~ r-var))) - r-var)]))) - pattern'))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) - - _ - (fail "update@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (update@ (~ (tag$ slot')) (~ fun) (~ _record)))))))) - - _ - (fail "Wrong syntax for update@"))) - -(defmacro #export (\template tokens) - (case tokens - (\ (list (#Meta [_ (#TupleS data)]) - (#Meta [_ (#TupleS bindings)]) - (#Meta [_ (#TupleS templates)]))) - (case (: (Maybe (List Syntax)) - (do Maybe/Monad - [bindings' (map% Maybe/Monad get-ident bindings) - data' (map% Maybe/Monad tuple->list data)] - (let [apply (: (-> RepEnv (List Syntax)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - ;return)))) - (#Some output) - (return output) - - #None - (fail "Wrong syntax for \\template")) - - _ - (fail "Wrong syntax for \\template"))) - -(def #export complement - (All [a] (-> (-> a Bool) (-> a Bool))) - (. not)) - -## (defmacro #export (loop tokens) -## (case tokens -## (\ (list bindings body)) -## (let [pairs (as-pairs bindings) -## vars (map first pairs) -## inits (map second pairs)] -## (if (every? symbol? inits) -## (do Lux/Monad -## [inits' (map% Maybe/Monad get-ident inits) -## init-types (map% Maybe/Monad find-var-type inits')] -## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] -## (~ body)) -## (~@ inits)))))) -## (do Lux/Monad -## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)] -## (return (list (` (let [(~@ (interleave aliases inits))] -## (loop [(~@ (interleave vars aliases))] -## (~ body))))))))) - -## _ -## (fail "Wrong syntax for loop"))) diff --git a/input/lux/codata/stream.lux b/input/lux/codata/stream.lux deleted file mode 100644 index 1d6dd1b50..000000000 --- a/input/lux/codata/stream.lux +++ /dev/null @@ -1,133 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux (control (lazy #as L #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all) - (comonad #as CM #refer #all)) - (meta lux - macro - syntax) - (data (list #as l #refer (#only list list& List/Monad))))) - -## [Types] -(deftype #export (Stream a) - (Lazy (, a (Stream a)))) - -## [Utils] -(def (cycle' x xs init full) - (All [a] - (-> a (List a) a (List a) (Stream a))) - (case xs - #;Nil (cycle' init full init full) - (#;Cons [y xs']) (... [x (cycle' y xs' init full)]))) - -## [Functions] -(def #export (iterate f x) - (All [a] - (-> (-> a a) a (Stream a))) - (... [x (iterate f (f x))])) - -(def #export (repeat x) - (All [a] - (-> a (Stream a))) - (... [x (repeat x)])) - -(def #export (cycle xs) - (All [a] - (-> (List a) (Maybe (Stream a)))) - (case xs - #;Nil #;None - (#;Cons [x xs']) (#;Some (cycle' x xs' x xs')))) - -(do-template [ ] - [(def #export ( s) - (All [a] (-> (Stream a) )) - (let [[h t] (! s)] - ))] - - [head a h] - [tail (Stream a) t]) - -(def #export (@ idx s) - (All [a] (-> Int (Stream a) a)) - (let [[h t] (! s)] - (if (i> idx 0) - (@ (dec idx) t) - h))) - -(do-template [ ] - [(def #export ( det xs) - (All [a] - (-> (Stream a) (List a))) - (let [[x xs'] (! xs)] - (if - (list& x ( xs')) - (list)))) - - (def #export ( det xs) - (All [a] - (-> (Stream a) (Stream a))) - (let [[x xs'] (! xs)] - (if - ( xs') - xs))) - - (def #export ( det xs) - (All [a] - (-> (Stream a) (, (List a) (Stream a)))) - (let [[x xs'] (! xs)] - (if - (let [[tail next] ( xs')] - [(#;Cons [x tail]) next]) - [(list) xs])))] - - [take-while drop-while split-with (-> a Bool) (det x) det] - [take drop split Int (i> det 0) (dec det)] - ) - -(def #export (unfold step init) - (All [a b] - (-> (-> a (, a b)) a (Stream b))) - (let [[next x] (step init)] - (... [x (unfold step next)]))) - -(def #export (filter p xs) - (All [a] (-> (-> a Bool) (Stream a) (Stream a))) - (let [[x xs'] (! xs)] - (if (p x) - (... [x (filter p xs')]) - (filter p xs')))) - -(def #export (partition p xs) - (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a)))) - [(filter p xs) (filter (complement p) xs)]) - -## [Structures] -(defstruct #export Stream/Functor (Functor Stream) - (def (F;map f fa) - (let [[h t] (! fa)] - (... [(f h) (F;map f t)])))) - -(defstruct #export Stream/CoMonad (CoMonad Stream) - (def CM;_functor Stream/Functor) - (def CM;unwrap head) - (def (CM;split wa) - (:: Stream/Functor (F;map repeat wa)))) - -## [Pattern-matching] -(defsyntax #export (\stream body [patterns' (+^ id^)]) - (do Lux/Monad - [patterns (map% Lux/Monad macro-expand-1 patterns') - g!s (gensym "s") - #let [patterns+ (: (List Syntax) - (do List/Monad - [pattern (l;reverse patterns)] - (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] - (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) diff --git a/input/lux/control/comonad.lux b/input/lux/control/comonad.lux deleted file mode 100644 index 1830ff44f..000000000 --- a/input/lux/control/comonad.lux +++ /dev/null @@ -1,54 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (../functor #as F) - lux/data/list - lux/meta/macro) - -## Signatures -(defsig #export (CoMonad w) - (: (F;Functor w) - _functor) - (: (All [a] - (-> (w a) a)) - unwrap) - (: (All [a] - (-> (w a) (w (w a)))) - split)) - -## Functions -(def #export (extend w f ma) - (All [w a b] - (-> (CoMonad w) (-> (w a) b) (w a) (w b))) - (using w - (using ;;_functor - (F;map f (;;split ma))))) - -## Syntax -(defmacro #export (be tokens state) - (case tokens - (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) - (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (case var - (#;Meta [_ (#;TagS ["" "let"])]) - (` (;let (~ value) (~ body'))) - - _ - (` (extend (;lambda [(~ var)] (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (#;Right [state (list (` (;case (~ monad) - {#;return ;return #;bind ;bind} - (~ body'))))])) - - _ - (#;Left "Wrong syntax for be"))) diff --git a/input/lux/control/functor.lux b/input/lux/control/functor.lux deleted file mode 100644 index 6a9dcfff8..000000000 --- a/input/lux/control/functor.lux +++ /dev/null @@ -1,15 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## Signatures -(defsig #export (Functor f) - (: (All [a b] - (-> (-> a b) (f a) (f b))) - map)) diff --git a/input/lux/control/lazy.lux b/input/lux/control/lazy.lux deleted file mode 100644 index 22dac74fe..000000000 --- a/input/lux/control/lazy.lux +++ /dev/null @@ -1,47 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/meta macro) - (.. (functor #as F #refer #all) - (monad #as M #refer #all)) - (lux/data list)) - -## Types -(deftype #export (Lazy a) - (All [b] - (-> (-> a b) b))) - -## Syntax -(defmacro #export (... tokens state) - (case tokens - (\ (list value)) - (let [blank (symbol$ ["" ""])] - (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) - - _ - (#;Left "Wrong syntax for ..."))) - -## Functions -(def #export (! thunk) - (All [a] - (-> (Lazy a) a)) - (thunk id)) - -## Structs -(defstruct #export Lazy/Functor (Functor Lazy) - (def (F;map f ma) - (lambda [k] (ma (. k f))))) - -(defstruct #export Lazy/Monad (Monad Lazy) - (def M;_functor Lazy/Functor) - - (def (M;wrap a) - (... a)) - - (def M;join !)) diff --git a/input/lux/control/monad.lux b/input/lux/control/monad.lux deleted file mode 100644 index b5552f987..000000000 --- a/input/lux/control/monad.lux +++ /dev/null @@ -1,99 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (.. (functor #as F) - (monoid #as M)) - lux/meta/macro) - -## [Utils] -(def (foldL f init xs) - (All [a b] - (-> (-> a b a) a (List b) a)) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (foldL f (f init x) xs'))) - -(def (reverse xs) - (All [a] - (-> (List a) (List a))) - (foldL (lambda [tail head] (#;Cons [head tail])) - #;Nil - xs)) - -(def (as-pairs xs) - (All [a] (-> (List a) (List (, a a)))) - (case xs - (#;Cons [x1 (#;Cons [x2 xs'])]) - (#;Cons [[x1 x2] (as-pairs xs')]) - - _ - #;Nil)) - -## [Signatures] -(defsig #export (Monad m) - (: (F;Functor m) - _functor) - (: (All [a] - (-> a (m a))) - wrap) - (: (All [a] - (-> (m (m a)) (m a))) - join)) - -## [Syntax] -(defmacro #export (do tokens state) - (case tokens - ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) - (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) - (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (case var - (#;Meta [_ (#;TagS ["" "let"])]) - (` (;let (~ value) (~ body'))) - - _ - (` (;case ;;_functor - {#F;map F;map} - (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join)))) - ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) - )))) - body - (reverse (as-pairs bindings)))] - (#;Right [state (#;Cons [(` (;case (~ monad) - {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} - (~ body'))) - #;Nil])])) - - _ - (#;Left "Wrong syntax for do"))) - -## [Functions] -(def #export (bind m f ma) - (All [m a b] - (-> (Monad m) (-> a (m b)) (m a) (m b))) - (using m - (;;join (:: ;;_functor (F;map f ma))))) - -(def #export (map% m f xs) - (All [m a b] - (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) - (case xs - #;Nil - (:: m (;;wrap #;Nil)) - - (#;Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;;wrap (#;Cons [y ys]))) - )) diff --git a/input/lux/control/monoid.lux b/input/lux/control/monoid.lux deleted file mode 100644 index d32baabc5..000000000 --- a/input/lux/control/monoid.lux +++ /dev/null @@ -1,24 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## Signatures -(defsig #export (Monoid a) - (: a - unit) - (: (-> a a a) - ++)) - -## Constructors -(def #export (monoid$ unit ++) - (All [a] - (-> a (-> a a a) (Monoid a))) - (struct - (def unit unit) - (def ++ ++))) diff --git a/input/lux/data/bool.lux b/input/lux/data/bool.lux deleted file mode 100644 index d4f223612..000000000 --- a/input/lux/data/bool.lux +++ /dev/null @@ -1,33 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (monoid #as m)) - (.. (eq #as E) - (show #as S))) - -## [Structures] -(defstruct #export Bool/Eq (E;Eq Bool) - (def (E;= x y) - (if x - y - (not y)))) - -(defstruct #export Bool/Show (S;Show Bool) - (def (S;show x) - (if x "true" "false"))) - -(do-template [ ] - [(defstruct #export (m;Monoid Bool) - (def m;unit ) - (def (m;++ x y) - ( x y)))] - - [ Or/Monoid false or] - [And/Monoid true and] - ) diff --git a/input/lux/data/bounded.lux b/input/lux/data/bounded.lux deleted file mode 100644 index 9d2dabde1..000000000 --- a/input/lux/data/bounded.lux +++ /dev/null @@ -1,17 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## Signatures -(defsig #export (Bounded a) - (: a - top) - - (: a - bottom)) diff --git a/input/lux/data/char.lux b/input/lux/data/char.lux deleted file mode 100644 index 42e57509e..000000000 --- a/input/lux/data/char.lux +++ /dev/null @@ -1,20 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (.. (eq #as E) - (show #as S))) - -## [Structures] -(defstruct #export Char/Eq (E;Eq Char) - (def (E;= x y) - (_jvm_ceq x y))) - -(defstruct #export Char/Show (S;Show Char) - (def (S;show x) - ($ text:++ "#\"" (_jvm_invokevirtual java.lang.Object toString [] x []) "\""))) diff --git a/input/lux/data/dict.lux b/input/lux/data/dict.lux deleted file mode 100644 index 63a66d49b..000000000 --- a/input/lux/data/dict.lux +++ /dev/null @@ -1,83 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/data (eq #as E))) - -## Signatures -(defsig #export (Dict d) - (: (All [k v] - (-> k (d k v) (Maybe v))) - get) - (: (All [k v] - (-> k v (d k v) (d k v))) - put) - (: (All [k v] - (-> k (d k v) (d k v))) - remove)) - -## Types -(deftype #export (PList k v) - (| (#PList (, (E;Eq k) (List (, k v)))))) - -## Constructors -(def #export (plist eq) - (All [k v] - (-> (E;Eq k) (PList k v))) - (#PList [eq #;Nil])) - -## Utils -(def (pl-get eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (Maybe v))) - (case kvs - #;Nil - #;None - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Some v') - (pl-get eq k kvs')))) - -(def (pl-put eq k v kvs) - (All [k v] - (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - (#;Cons [[k v] kvs]) - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Cons [[k v] kvs']) - (#;Cons [[k' v'] (pl-put eq k v kvs')])))) - -(def (pl-remove eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - kvs - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - kvs' - (#;Cons [[k' v'] (pl-remove eq k kvs')])))) - -## Structs -(defstruct #export PList/Dict (Dict PList) - (def (get k plist) - (let [(#PList [eq kvs]) plist] - (pl-get eq k kvs))) - - (def (put k v plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-put eq k v kvs)]))) - - (def (remove k plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-remove eq k kvs)])))) diff --git a/input/lux/data/either.lux b/input/lux/data/either.lux deleted file mode 100644 index 7166688b5..000000000 --- a/input/lux/data/either.lux +++ /dev/null @@ -1,46 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/data (list #refer (#except partition)))) - -## [Types] -## (deftype (Either l r) -## (| (#;Left l) -## (#;Right r))) - -## [Functions] -(def #export (either f g e) - (All [a b c] (-> (-> a c) (-> b c) (Either a b) c)) - (case e - (#;Left x) (f x) - (#;Right x) (g x))) - -(do-template [ ] - [(def #export ( es) - (All [a b] (-> (List (Either a b)) (List ))) - (case es - #;Nil #;Nil - (#;Cons [( x) es']) (#;Cons [x ( es')]) - (#;Cons [_ es']) ( es')))] - - [lefts a #;Left] - [rights b #;Right] - ) - -(def #export (partition es) - (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) - (foldL (: (All [a b] - (-> (, (List a) (List b)) (Either a b) (, (List a) (List b)))) - (lambda [tails e] - (let [[ltail rtail] tails] - (case e - (#;Left x) [(#;Cons [x ltail]) rtail] - (#;Right x) [ltail (#;Cons [x rtail])])))) - [(list) (list)] - (reverse es))) diff --git a/input/lux/data/eq.lux b/input/lux/data/eq.lux deleted file mode 100644 index be3400208..000000000 --- a/input/lux/data/eq.lux +++ /dev/null @@ -1,14 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## [Signatures] -(defsig #export (Eq a) - (: (-> a a Bool) - =)) diff --git a/input/lux/data/error.lux b/input/lux/data/error.lux deleted file mode 100644 index cb5c309a6..000000000 --- a/input/lux/data/error.lux +++ /dev/null @@ -1,34 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Error a) - (| (#Fail Text) - (#Ok a))) - -## [Structures] -(defstruct #export Error/Functor (Functor Error) - (def (F;map f ma) - (case ma - (#Fail msg) (#Fail msg) - (#Ok datum) (#Ok (f datum))))) - -(defstruct #export Error/Monad (Monad Error) - (def M;_functor Error/Functor) - - (def (M;wrap a) - (#Ok a)) - - (def (M;join mma) - (case mma - (#Fail msg) (#Fail msg) - (#Ok ma) ma))) diff --git a/input/lux/data/id.lux b/input/lux/data/id.lux deleted file mode 100644 index 0e3bdbee6..000000000 --- a/input/lux/data/id.lux +++ /dev/null @@ -1,28 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Id a) - (| (#Id a))) - -## [Structures] -(defstruct #export Id/Functor (Functor Id) - (def (F;map f fa) - (let [(#Id a) fa] - (#Id (f a))))) - -(defstruct #export Id/Monad (Monad Id) - (def M;_functor Id/Functor) - (def (M;wrap a) (#Id a)) - (def (M;join mma) - (let [(#Id ma) mma] - ma))) diff --git a/input/lux/data/io.lux b/input/lux/data/io.lux deleted file mode 100644 index c08023df5..000000000 --- a/input/lux/data/io.lux +++ /dev/null @@ -1,51 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/meta macro) - (lux/control (functor #as F) - (monad #as M)) - lux/data/list) - -## Types -(deftype #export (IO a) - (-> (,) a)) - -## Syntax -(defmacro #export (io tokens state) - (case tokens - (\ (list value)) - (let [blank (symbol$ ["" ""])] - (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))])) - - _ - (#;Left "Wrong syntax for io"))) - -## Structures -(defstruct #export IO/Functor (F;Functor IO) - (def (F;map f ma) - (io (f (ma []))))) - -(defstruct #export IO/Monad (M;Monad IO) - (def M;_functor IO/Functor) - - (def (M;wrap x) - (io x)) - - (def (M;join mma) - (mma []))) - -## Functions -(def #export (print x) - (-> Text (IO (,))) - (io (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) [x]))) - -(def #export (println x) - (-> Text (IO (,))) - (print (text:++ x "\n"))) diff --git a/input/lux/data/list.lux b/input/lux/data/list.lux deleted file mode 100644 index 450dee275..000000000 --- a/input/lux/data/list.lux +++ /dev/null @@ -1,250 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all)) - lux/meta/macro) - -## Types -## (deftype (List a) -## (| #Nil -## (#Cons (, a (List a))))) - -## Functions -(def #export (foldL f init xs) - (All [a b] - (-> (-> a b a) a (List b) a)) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (foldL f (f init x) xs'))) - -(def #export (foldR f init xs) - (All [a b] - (-> (-> b a a) a (List b) a)) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (f x (foldR f init xs')))) - -(def #export (reverse xs) - (All [a] - (-> (List a) (List a))) - (foldL (lambda [tail head] (#;Cons [head tail])) - #;Nil - xs)) - -(def #export (filter p xs) - (All [a] - (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - #;Nil - - (#;Cons [x xs']) - (if (p x) - (#;Cons [x (filter p xs')]) - (filter p xs')))) - -(def #export (partition p xs) - (All [a] (-> (-> a Bool) (List a) (, (List a) (List a)))) - [(filter p xs) (filter (complement p) xs)]) - -(def #export (as-pairs xs) - (All [a] (-> (List a) (List (, a a)))) - (case xs - (\ (#;Cons [x1 (#;Cons [x2 xs'])])) - (#;Cons [[x1 x2] (as-pairs xs')]) - - _ - #;Nil)) - -(do-template [ ] - [(def #export ( n xs) - (All [a] - (-> Int (List a) (List a))) - (if (i> n 0) - (case xs - #;Nil - #;Nil - - (#;Cons [x xs']) - ) - ))] - - [take (#;Cons [x (take (dec n) xs')]) #;Nil] - [drop (drop (dec n) xs') xs] - ) - -(do-template [ ] - [(def #export ( p xs) - (All [a] - (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - #;Nil - - (#;Cons [x xs']) - (if (p x) - - )))] - - [take-while (#;Cons [x (take-while p xs')]) #;Nil] - [drop-while (drop-while p xs') xs] - ) - -(def #export (split n xs) - (All [a] - (-> Int (List a) (, (List a) (List a)))) - (if (i> n 0) - (case xs - #;Nil - [#;Nil #;Nil] - - (#;Cons [x xs']) - (let [[tail rest] (split (dec n) xs')] - [(#;Cons [x tail]) rest])) - [#;Nil xs])) - -(def (split-with' p ys xs) - (All [a] - (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) - (case xs - #;Nil - [ys xs] - - (#;Cons [x xs']) - (if (p x) - (split-with' p (#;Cons [x ys]) xs') - [ys xs]))) - -(def #export (split-with p xs) - (All [a] - (-> (-> a Bool) (List a) (, (List a) (List a)))) - (let [[ys' xs'] (split-with' p #;Nil xs)] - [(reverse ys') xs'])) - -(def #export (repeat n x) - (All [a] - (-> Int a (List a))) - (if (i> n 0) - (#;Cons [x (repeat (dec n) x)]) - #;Nil)) - -(def #export (iterate f x) - (All [a] - (-> (-> a (Maybe a)) a (List a))) - (case (f x) - (#;Some x') - (#;Cons [x (iterate f x')]) - - #;None - (#;Cons [x #;Nil]))) - -(def #export (some f xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #;Nil - #;None - - (#;Cons [x xs']) - (case (f x) - #;None - (some f xs') - - (#;Some y) - (#;Some y)))) - -(def #export (interpose sep xs) - (All [a] - (-> a (List a) (List a))) - (case xs - #;Nil - xs - - (#;Cons [x #;Nil]) - xs - - (#;Cons [x xs']) - (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) - -(def #export (size list) - (-> List Int) - (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) - -(do-template [ ] - [(def #export ( p xs) - (All [a] - (-> (-> a Bool) (List a) Bool)) - (foldL (lambda [_1 _2] ( _1 (p _2))) xs))] - - [every? true and] - [any? false or]) - -(def #export (@ i xs) - (All [a] - (-> Int (List a) (Maybe a))) - (case xs - #;Nil - #;None - - (#;Cons [x xs']) - (if (i= 0 i) - (#;Some x) - (@ (dec i) xs')))) - -## Syntax -(defmacro #export (list xs state) - (#;Right [state (#;Cons [(foldL (lambda [tail head] - (` (#;Cons [(~ head) (~ tail)]))) - (` #;Nil) - (reverse xs)) - #;Nil])])) - -(defmacro #export (list& xs state) - (case (reverse xs) - (#;Cons [last init]) - (#;Right [state (list (foldL (lambda [tail head] - (` (#;Cons [(~ head) (~ tail)]))) - last - init))]) - - _ - (#;Left "Wrong syntax for list&"))) - -## Structures -(defstruct #export List/Monoid (All [a] - (Monoid (List a))) - (def m;unit #;Nil) - (def (m;++ xs ys) - (case xs - #;Nil ys - (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)])))) - -(defstruct #export List/Functor (Functor List) - (def (F;map f ma) - (case ma - #;Nil #;Nil - (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')])))) - -(defstruct #export List/Monad (Monad List) - (def M;_functor List/Functor) - - (def (M;wrap a) - (#;Cons [a #;Nil])) - - (def (M;join mma) - (using List/Monoid - (foldL m;++ m;unit mma)))) diff --git a/input/lux/data/maybe.lux b/input/lux/data/maybe.lux deleted file mode 100644 index faec53c2e..000000000 --- a/input/lux/data/maybe.lux +++ /dev/null @@ -1,42 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -## (deftype (Maybe a) -## (| #;None -## (#;Some a))) - -## [Structures] -(defstruct #export Maybe/Monoid (Monoid Maybe) - (def m;unit #;None) - (def (m;++ xs ys) - (case xs - #;None ys - (#;Some x) (#;Some x)))) - -(defstruct #export Maybe/Functor (Functor Maybe) - (def (F;map f ma) - (case ma - #;None #;None - (#;Some a) (#;Some (f a))))) - -(defstruct #export Maybe/Monad (Monad Maybe) - (def M;_functor Maybe/Functor) - - (def (M;wrap x) - (#;Some x)) - - (def (M;join mma) - (case mma - #;None #;None - (#;Some xs) xs))) diff --git a/input/lux/data/number.lux b/input/lux/data/number.lux deleted file mode 100644 index 8da674d88..000000000 --- a/input/lux/data/number.lux +++ /dev/null @@ -1,119 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (monoid #as m)) - (lux/data (eq #as E) - (ord #as O) - (bounded #as B) - (show #as S))) - -## Signatures -(defsig #export (Number n) - (do-template [] - [(: (-> n n n) )] - [+] [-] [*] [/] [%]) - - (: (-> Int n) - from-int) - - (do-template [] - [(: (-> n n) )] - [negate] [signum] [abs]) - ) - -## [Structures] -## Number -(do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] - [(defstruct #export (Number ) - (def + <+>) - (def - <->) - (def * <*>) - (def / ) - (def % <%>) - (def (from-int x) - ( x)) - (def (negate x) - (<*> <-1> x)) - (def (abs x) - (if (<<> x <0>) - (<*> <-1> x) - x)) - (def (signum x) - (cond (<=> x <0>) <0> - (<<> x <0>) <-1> - ## else - <1>)) - )] - - [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1] - [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0]) - -## Eq -(defstruct #export Int/Eq (E;Eq Int) - (def E;= i=)) - -(defstruct #export Real/Eq (E;Eq Real) - (def E;= r=)) - -## Ord -## (def #export Int/Ord (O;Ord Int) -## (O;ord$ Int/Eq i< i>)) - -## (def #export Real/Ord (O;Ord Real) -## (O;ord$ Real/Eq r< r>)) - -(do-template [ ] - [(defstruct #export (O;Ord ) - (def O;_eq ) - (def O;< ) - (def (O;<= x y) - (or ( x y) - (using (E;= x y)))) - (def O;> ) - (def (O;>= x y) - (or ( x y) - (using (E;= x y)))))] - - [ Int/Ord Int Int/Eq i< i>] - [Real/Ord Real Real/Eq r< r>]) - -## Bounded -(do-template [ ] - [(defstruct #export (B;Bounded ) - (def B;top ) - (def B;bottom ))] - - [ Int/Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] - [Real/Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) - -## Monoid -(do-template [ <++>] - [(defstruct #export (m;Monoid ) - (def m;unit ) - (def m;++ <++>))] - - [ IntAdd/Monoid Int 0 i+] - [ IntMul/Monoid Int 1 i*] - [RealAdd/Monoid Real 0.0 r+] - [RealMul/Monoid Real 1.0 r*] - [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] - [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] - [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] - [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] - ) - -## Show -(do-template [ ] - [(defstruct #export (S;Show ) - (def (S;show x) - ))] - - [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] - [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] - ) diff --git a/input/lux/data/ord.lux b/input/lux/data/ord.lux deleted file mode 100644 index 80f2e4fb5..000000000 --- a/input/lux/data/ord.lux +++ /dev/null @@ -1,44 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (../eq #as E)) - -## [Signatures] -(defsig #export (Ord a) - (: (E;Eq a) - _eq) - (do-template [] - [(: (-> a a Bool) )] - - [<] [<=] [>] [>=])) - -## [Constructors] -(def #export (ord$ eq < >) - (All [a] - (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) - (struct - (def _eq eq) - (def < <) - (def (<= x y) - (or (< x y) - (:: eq (E;= x y)))) - (def > >) - (def (>= x y) - (or (> x y) - (:: eq (E;= x y)))))) - -## [Functions] -(do-template [ ] - [(def #export ( ord x y) - (All [a] - (-> (Ord a) a a a)) - (if (:: ord ( x y)) x y))] - - [max ;;>] - [min ;;<]) diff --git a/input/lux/data/reader.lux b/input/lux/data/reader.lux deleted file mode 100644 index c3bbc2830..000000000 --- a/input/lux/data/reader.lux +++ /dev/null @@ -1,33 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import (lux #refer (#except Reader)) - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Reader r a) - (-> r a)) - -## [Structures] -(defstruct #export Reader/Functor (All [r] - (Functor (Reader r))) - (def (F;map f fa) - (lambda [env] - (f (fa env))))) - -(defstruct #export Reader/Monad (All [r] - (Monad (Reader r))) - (def M;_functor Reader/Functor) - - (def (M;wrap x) - (lambda [env] x)) - - (def (M;join mma) - (lambda [env] - (mma env env)))) diff --git a/input/lux/data/show.lux b/input/lux/data/show.lux deleted file mode 100644 index f4e1cf762..000000000 --- a/input/lux/data/show.lux +++ /dev/null @@ -1,14 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## Signatures -(defsig #export (Show a) - (: (-> a Text) - show)) diff --git a/input/lux/data/state.lux b/input/lux/data/state.lux deleted file mode 100644 index bc9858a29..000000000 --- a/input/lux/data/state.lux +++ /dev/null @@ -1,35 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (State s a) - (-> s (, s a))) - -## [Structures] -(defstruct #export State/Functor (Functor State) - (def (F;map f ma) - (lambda [state] - (let [[state' a] (ma state)] - [state' (f a)])))) - -(defstruct #export State/Monad (All [s] - (Monad (State s))) - (def M;_functor State/Functor) - - (def (M;wrap x) - (lambda [state] - [state x])) - - (def (M;join mma) - (lambda [state] - (let [[state' ma] (mma state)] - (ma state'))))) diff --git a/input/lux/data/text.lux b/input/lux/data/text.lux deleted file mode 100644 index a3192a1d5..000000000 --- a/input/lux/data/text.lux +++ /dev/null @@ -1,146 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (monoid #as m)) - (lux/data (eq #as E) - (ord #as O) - (show #as S))) - -## [Functions] -(def #export (size x) - (-> Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String length [] - x []))) - -(def #export (@ idx x) - (-> Int Text (Maybe Char)) - (if (and (i< idx (size x)) - (i>= idx 0)) - (#;Some (_jvm_invokevirtual java.lang.String charAt [int] - x [(_jvm_l2i idx)])) - #;None)) - -(def #export (contains? x y) - (-> Text Text Bool) - (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence] - x [y])) - -(do-template [ ] - [(def #export ( x) - (-> Text Text) - (_jvm_invokevirtual java.lang.String [] - x []))] - [lower-case toLowerCase] - [upper-case toUpperCase] - [trim trim] - ) - -(def #export (sub' from to x) - (-> Int Int Text (Maybe Text)) - (if (and (i< from to) - (i>= from 0) - (i<= to (size x))) - (_jvm_invokevirtual java.lang.String substring [int int] - x [(_jvm_l2i from) (_jvm_l2i to)]) - #;None)) - -(def #export (sub from x) - (-> Int Text (Maybe Text)) - (sub' from (size x) x)) - -(def #export (split at x) - (-> Int Text (Maybe (, Text Text))) - (if (and (i< at (size x)) - (i>= at 0)) - (let [pre (_jvm_invokevirtual java.lang.String substring [int int] - x [(_jvm_l2i 0) (_jvm_l2i at)]) - post (_jvm_invokevirtual java.lang.String substring [int] - x [(_jvm_l2i at)])] - (#;Some [pre post])) - #;None)) - -(def #export (replace pattern value template) - (-> Text Text Text Text) - (_jvm_invokevirtual java.lang.String replace [java.lang.CharSequence java.lang.CharSequence] - template [pattern value])) - -(do-template [ ] - [(def #export ( pattern from x) - (-> Text Int Text (Maybe Int)) - (if (and (i< from (size x)) (i>= from 0)) - (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String int] - x [pattern (_jvm_l2i from)])) - -1 #;None - idx (#;Some idx)) - #;None)) - - (def #export ( pattern x) - (-> Text Text (Maybe Int)) - (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String] - x [pattern])) - -1 #;None - idx (#;Some idx)))] - - [index-of index-of' indexOf] - [last-index-of last-index-of' lastIndexOf] - ) - -(def #export (starts-with? prefix x) - (-> Text Text Bool) - (case (index-of prefix x) - (#;Some 0) - true - - _ - false)) - -(def #export (ends-with? postfix x) - (-> Text Text Bool) - (case (last-index-of postfix x) - (#;Some n) - (i= (i+ n (size postfix)) - (size x)) - - _ - false)) - -## [Structures] -(defstruct #export Text/Eq (E;Eq Text) - (def (E;= x y) - (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] - x [y]))) - -(defstruct #export Text/Ord (O;Ord Text) - (def O;_eq Text/Eq) - (def (O;< x y) - (i< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) - (def (O;<= x y) - (i<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) - (def (O;> x y) - (i> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) - (def (O;>= x y) - (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0))) - -(defstruct #export Text/Show (S;Show Text) - (def (S;show x) - x)) - -(defstruct #export Text/Monoid (m;Monoid Text) - (def m;unit "") - (def (m;++ x y) - (_jvm_invokevirtual java.lang.String concat [java.lang.String] - x [y]))) diff --git a/input/lux/data/writer.lux b/input/lux/data/writer.lux deleted file mode 100644 index f71492e35..000000000 --- a/input/lux/data/writer.lux +++ /dev/null @@ -1,34 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Writer l a) - (, l a)) - -## [Structures] -(defstruct #export Writer/Functor (All [l] - (Functor (Writer l))) - (def (F;map f fa) - (let [[log datum] fa] - [log (f datum)]))) - -(defstruct #export (Writer/Monad mon) (All [l] - (-> (Monoid l) (Monad (Writer l)))) - (def M;_functor Writer/Functor) - - (def (M;wrap x) - [(:: mon m;unit) x]) - - (def (M;join mma) - (let [[log1 [log2 a]] mma] - [(:: mon (m;++ log1 log2)) a]))) diff --git a/input/lux/host/java.lux b/input/lux/host/java.lux deleted file mode 100644 index 12525d3f2..000000000 --- a/input/lux/host/java.lux +++ /dev/null @@ -1,312 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux (control (monoid #as m) - (functor #as F) - (monad #as M #refer (#only do))) - (data list - (text #as text)) - (meta lux - macro - syntax))) - -## (open List/Functor) - -## [Utils/Parsers] -(def finally^ - (Parser Syntax) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "finally"]) - expr id^ - _ end^] - (M;wrap expr)))) - -(def catch^ - (Parser (, Text Ident Syntax)) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "catch"]) - ex-class local-symbol^ - ex symbol^ - expr id^ - _ end^] - (M;wrap [ex-class ex expr])))) - -(def method-decl^ - (Parser (, (List Text) Text (List Text) Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ local-symbol^)) - output local-symbol^ - _ end^] - (M;wrap [modifiers name inputs output])))) - -(def field-decl^ - (Parser (, (List Text) Text Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - class local-symbol^ - _ end^] - (M;wrap [modifiers name class])))) - -(def arg-decl^ - (Parser (, Text Text)) - (form^ (do Parser/Monad - [arg-name local-symbol^ - arg-class local-symbol^ - _ end^] - (M;wrap [arg-name arg-class])))) - -(def method-def^ - (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ arg-decl^)) - output local-symbol^ - body id^ - _ end^] - (M;wrap [modifiers name inputs output body])))) - -(def method-call^ - (Parser (, Text (List Text) (List Syntax))) - (form^ (do Parser/Monad - [method local-symbol^ - arity-classes (tuple^ (*^ local-symbol^)) - arity-args (tuple^ (*^ id^)) - _ end^ - _ (: (Parser (,)) - (if (i= (size arity-classes) - (size arity-args)) - (M;wrap []) - (lambda [_] #;None)))] - (M;wrap [method arity-classes arity-args]) - ))) - -## [Utils/Lux] -## (def (find-class-field field class) -## (-> Text Text (Lux Type)) -## ...) - -## (def (find-virtual-method method class) -## (-> Text Text (Lux (List (, (List Type) Type)))) -## ...) - -## (def (find-static-method method class) -## (-> Text Text (Lux (List (, (List Type) Type)))) -## ...) - - -## [Syntax] -(defsyntax #export (throw ex) - (emit (list (` (_jvm_throw (~ ex)))))) - -(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) - (emit (list (` (_jvm_try (~ body) - (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax) - (lambda [catch] - (let [[class ex body] catch] - (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches)) - (case finally - #;None - (list) - - (#;Some finally) - (list (` (_jvm_finally (~ finally)))))))))))) - -(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (do Lux/Monad - [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name))]] - (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) - members))] - (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))] - (~@ members')))))))) - -(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] - [fields (*^ field-decl^)] - [methods (*^ method-def^)]) - (do Lux/Monad - [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name)) - fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (symbol$ ["" name])) - (~ (text$ class)) - [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) - fields)) - methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (symbol$ ["" name])) - [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) - (lambda [in] - (let [[left right] in] - (form$ (list (text$ left) - (text$ right)))))) - inputs)))] - (~ (text$ output)) - [(~@ (:: List/Functor (F;map text$ modifiers)))] - (~ body)))))) - methods))]] - (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) - [(~@ (:: List/Functor (F;map text$ interfaces)))] - [(~@ fields')] - [(~@ methods')])))))) - -(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) - (emit (list (` (_jvm_new (~ (text$ class)) - [(~@ (:: List/Functor (F;map text$ arg-classes)))] - [(~@ args)]))))) - -(defsyntax #export (instance? [class local-symbol^] obj) - (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) - -(defsyntax #export (locking lock body) - (do Lux/Monad - [g!lock (gensym "") - g!body (gensym "")] - (emit (list (` (;let [(~ g!lock) (~ lock) - _ (_jvm_monitor-enter (~ g!lock)) - (~ g!body) (~ body) - _ (_jvm_monitor-exit (~ g!lock))] - (~ g!body))))) - )) - -(defsyntax #export (null? obj) - (emit (list (` (_jvm_null? (~ obj)))))) - -(defsyntax #export (program [args symbol^] body) - (emit (list (` (_jvm_program (~ (symbol$ args)) - (~ body)))))) - -## (defsyntax #export (.? [field local-symbol^] obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [field-class (find-field field class)] -## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)))) - -## _ -## (fail "Can only get field from object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.? (~ field) (~ g!obj))))))))) - -## (defsyntax #export (.= [field local-symbol^] value obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [field-class (find-field field class)] -## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value))) - -## _ -## (fail "Can only set field of object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.= (~ field) (~ value) (~ g!obj))))))))) - -## (defsyntax #export (.! [call method-call^] obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [#let [[m-name ?m-classes m-args] call] -## all-m-details (find-virtual-method m-name class) -## m-ins (case [?m-classes all-m-details] -## (\ [#;None (list [m-ins m-out])]) -## (M;wrap m-ins) - -## (\ [(#;Some m-ins) _]) -## (M;wrap m-ins) - -## _ -## #;None)] -## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))] -## (~ obj) [(~@ m-args)]))))) - -## _ -## (fail "Can only call method on object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.! (~@ *tokens*))))))))) - -## (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) -## (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) - -## (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) -## (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) - -## (defsyntax #export (..! [call method-call^] [class local-symbol^]) -## (do Lux/Monad -## [#let [[m-name ?m-classes m-args] call] -## all-m-details (find-static-method m-name class) -## m-ins (case [?m-classes all-m-details] -## (\ [#;None (list [m-ins m-out])]) -## (M;wrap m-ins) - -## (\ [(#;Some m-ins) _]) -## (M;wrap m-ins) - -## _ -## #;None)] -## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class)) -## [(~@ (:: List/Functor (F;map text$ m-ins)))] -## [(~@ m-args)])))) -## )) - -## (definterface Function [] -## (#public #abstract apply [java.lang.Object] java.lang.Object)) - -## (_jvm_interface "Function" [] -## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) - -## (defclass MyFunction [Function] -## (#public #static foo java.lang.Object) -## (#public [] void -## (_jvm_invokespecial java.lang.Object [] this [])) -## (#public apply [(arg java.lang.Object)] java.lang.Object -## "YOLO")) - -## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] -## [(foo "java.lang.Object" ["public" "static"])] -## ( [] "void" -## ["public"] -## (_jvm_invokespecial java.lang.Object [] this [])) -## (apply [(arg "java.lang.Object")] "java.lang.Object" -## ["public"] -## "YOLO")) diff --git a/input/lux/math.lux b/input/lux/math.lux deleted file mode 100644 index 2e29c5da7..000000000 --- a/input/lux/math.lux +++ /dev/null @@ -1,60 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## [Constants] -(do-template [ ] - [(def #export - Real - (_jvm_getstatic java.lang.Math ))] - - [e E] - [pi PI] - ) - -## [Functions] -(do-template [ ] - [(def #export ( n) - (-> Real Real) - (_jvm_invokestatic java.lang.Math [double] [n]))] - - [cos cos] - [sin sin] - [tan tan] - - [acos acos] - [asin asin] - [atan atan] - - [cosh cosh] - [sinh sinh] - [tanh tanh] - - [ceil ceil] - [floor floor] - [round round] - - [exp exp] - [log log] - - [cbrt cbrt] - [sqrt sqrt] - - [->degrees toDegrees] - [->radians toRadians] - ) - -(do-template [ ] - [(def #export ( x y) - (-> Real Real Real) - (_jvm_invokestatic java.lang.Math [double double] [x y]))] - - [atan2 atan2] - [pow pow] - ) diff --git a/input/lux/meta/lux.lux b/input/lux/meta/lux.lux deleted file mode 100644 index a28d6e5d4..000000000 --- a/input/lux/meta/lux.lux +++ /dev/null @@ -1,287 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (.. macro) - (lux/control (monoid #as m) - (functor #as F) - (monad #as M #refer (#only do))) - (lux/data list - maybe - (show #as S) - (number #as N))) - -## [Types] -## (deftype (Lux a) -## (-> Compiler (Either Text (, Compiler a)))) - -## [Utils] -(def (ident->text ident) - (-> Ident Text) - (let [[pre post] ident] - ($ text:++ pre ";" post))) - -## [Structures] -(defstruct #export Lux/Functor (F;Functor Lux) - (def (F;map f fa) - (lambda [state] - (case (fa state) - (#;Left msg) - (#;Left msg) - - (#;Right [state' a]) - (#;Right [state' (f a)]))))) - -(defstruct #export Lux/Monad (M;Monad Lux) - (def M;_functor Lux/Functor) - (def (M;wrap x) - (lambda [state] - (#;Right [state x]))) - (def (M;join mma) - (lambda [state] - (case (mma state) - (#;Left msg) - (#;Left msg) - - (#;Right [state' ma]) - (ma state'))))) - -## Functions -(def #export (get-module-name state) - (Lux Text) - (case (reverse (get@ #;envs state)) - #;Nil - (#;Left "Can't get the module name without a module!") - - (#;Cons [env _]) - (#;Right [state (get@ #;name env)]))) - -(def (get k plist) - (All [a] - (-> Text (List (, Text a)) (Maybe a))) - (case plist - #;Nil - #;None - - (#;Cons [[k' v] plist']) - (if (text:= k k') - (#;Some v) - (get k plist')))) - -(def (find-macro' modules current-module module name) - (-> (List (, Text (Module Compiler))) Text Text Text - (Maybe Macro)) - (do Maybe/Monad - [$module (get module modules) - gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))] - (case (: (, Bool (DefData' Macro)) gdef) - [exported? (#;MacroD macro')] - (if (or exported? (text:= module current-module)) - (#;Some macro') - #;None) - - [_ (#;AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) - - _ - #;None))) - -(def #export (find-macro ident) - (-> Ident (Lux (Maybe Macro))) - (do Lux/Monad - [current-module get-module-name] - (let [[module name] ident] - (: (Lux (Maybe Macro)) - (lambda [state] - (#;Right [state (find-macro' (get@ #;modules state) current-module module name)])))))) - -(def #export (normalize ident) - (-> Ident (Lux Ident)) - (case ident - ["" name] - (do Lux/Monad - [module-name get-module-name] - (M;wrap (: Ident [module-name name]))) - - _ - (:: Lux/Monad (M;wrap ident)))) - -(def #export (macro-expand syntax) - (-> Syntax (Lux (List Syntax))) - (case syntax - (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) - (do Lux/Monad - [macro-name' (normalize macro-name) - ?macro (find-macro macro-name')] - (case ?macro - (#;Some macro) - (do Lux/Monad - [expansion (macro args) - expansion' (M;map% Lux/Monad macro-expand expansion)] - (M;wrap (:: List/Monad (M;join expansion')))) - - #;None - (do Lux/Monad - [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] - (M;wrap (list (form$ (:: List/Monad (M;join parts')))))))) - - (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) - (do Lux/Monad - [harg+ (macro-expand harg) - targs+ (M;map% Lux/Monad macro-expand targs)] - (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+)))))))) - - (#;Meta [_ (#;TupleS members)]) - (do Lux/Monad - [members' (M;map% Lux/Monad macro-expand members)] - (M;wrap (list (tuple$ (:: List/Monad (M;join members')))))) - - _ - (:: Lux/Monad (M;wrap (list syntax))))) - -(def #export (gensym prefix state) - (-> Text (Lux Syntax)) - (#;Right [(update@ #;seed inc state) - (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed state)))])])) - -(def #export (emit datum) - (All [a] - (-> a (Lux a))) - (lambda [state] - (#;Right [state datum]))) - -(def #export (fail msg) - (All [a] - (-> Text (Lux a))) - (lambda [_] - (#;Left msg))) - -(def #export (macro-expand-1 token) - (-> Syntax (Lux Syntax)) - (do Lux/Monad - [token+ (macro-expand token)] - (case token+ - (\ (list token')) - (M;wrap token') - - _ - (fail "Macro expanded to more than 1 element.")))) - -(def #export (module-exists? module state) - (-> Text (Lux Bool)) - (#;Right [state (case (get module (get@ #;modules state)) - (#;Some _) - true - - #;None - false)])) - -(def #export (exported-defs module state) - (-> Text (Lux (List Text))) - (case (get module (get@ #;modules state)) - (#;Some =module) - (using List/Monad - (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (list name) - (list))))) - (get@ #;defs =module))))])) - - #;None - (#;Left ($ text:++ "Unknown module: " module)))) - -(def (show-envs envs) - (-> (List (Env Text (, LuxVar Type))) Text) - (|> envs - (F;map (lambda [env] - (case env - {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _} - ($ text:++ name ": " (|> locals - (F;map (: (All [a] (-> (, Text a) Text)) - (lambda [b] (let [[label _] b] label)))) - (:: List/Functor) - (interpose " ") - (foldL text:++ "")))))) - (:: List/Functor) - (interpose "\n") - (foldL text:++ ""))) - -(def (try-both f x1 x2) - (All [a b] - (-> (-> a (Maybe b)) a a (Maybe b))) - (case (f x1) - #;None (f x2) - (#;Some y) (#;Some y))) - -(def (find-in-env name state) - (-> Ident Compiler (Maybe Type)) - (let [vname' (ident->text name)] - (case state - {#;source source #;modules modules - #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} - (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} - (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#;Some type) - #;None))))) - locals - closure)))) - envs)))) - -(def (find-in-defs name state) - (-> Ident Compiler (Maybe Type)) - (let [[v-prefix v-name] name - {#;source source #;modules modules - #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} state] - (case (get v-prefix modules) - #;None - #;None - - (#;Some {#;defs defs #;module-aliases _ #;imports _}) - (case (get v-name defs) - #;None - #;None - - (#;Some [_ def-data]) - (case def-data - #;TypeD (#;Some Type) - (#;ValueD type) (#;Some type) - (#;MacroD m) (#;Some Macro) - (#;AliasD name') (find-in-defs name' state)))))) - -(def #export (find-var-type name) - (-> Ident (Lux Type)) - (do Lux/Monad - [name' (normalize name)] - (: (Lux Type) - (lambda [state] - (case (find-in-env name state) - (#;Some struct-type) - (#;Right [state struct-type]) - - _ - (case (find-in-defs name' state) - (#;Some struct-type) - (#;Right [state struct-type]) - - _ - (let [{#;source source #;modules modules - #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} state] - (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) - )) diff --git a/input/lux/meta/macro.lux b/input/lux/meta/macro.lux deleted file mode 100644 index 22aeaf874..000000000 --- a/input/lux/meta/macro.lux +++ /dev/null @@ -1,54 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## [Utils] -(def (_meta x) - (-> (Syntax' (Meta Cursor)) Syntax) - (#;Meta [["" -1 -1] x])) - -## [Syntax] -(def #export (defmacro tokens state) - Macro - (case tokens - (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) - (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) - (~ (_meta (#;SymbolS ["lux" "Macro"]))) - (~ body))) - (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) - #;Nil])])]) - - (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) - (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args)) - (~ (_meta (#;SymbolS ["lux" "Macro"]))) - (~ body))) - (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) - #;Nil])])]) - - _ - (#;Left "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) - -## [Functions] -(do-template [ ] - [(def #export ( x) - (-> Syntax) - (#;Meta [["" -1 -1] ( x)]))] - - [bool$ Bool #;BoolS] - [int$ Int #;IntS] - [real$ Real #;RealS] - [char$ Char #;CharS] - [text$ Text #;TextS] - [symbol$ Ident #;SymbolS] - [tag$ Ident #;TagS] - [form$ (List Syntax) #;FormS] - [tuple$ (List Syntax) #;TupleS] - [record$ (List (, Syntax Syntax)) #;RecordS] - ) diff --git a/input/lux/meta/syntax.lux b/input/lux/meta/syntax.lux deleted file mode 100644 index 1fe85c32f..000000000 --- a/input/lux/meta/syntax.lux +++ /dev/null @@ -1,262 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (.. (macro #as m #refer #all) - (lux #as l #refer (#only Lux/Monad gensym))) - (lux (control (functor #as F) - (monad #as M #refer (#only do))) - (data (eq #as E) - (bool #as b) - (char #as c) - (text #as t) - list))) - -## [Utils] -(def (first xy) - (All [a b] (-> (, a b) a)) - (let [[x y] xy] - x)) - -(def (join-pairs pairs) - (All [a] (-> (List (, a a)) (List a))) - (case pairs - #;Nil #;Nil - (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) - -## Types -(deftype #export (Parser a) - (-> (List Syntax) (Maybe (, (List Syntax) a)))) - -## Structures -(defstruct #export Parser/Functor (F;Functor Parser) - (def (F;map f ma) - (lambda [tokens] - (case (ma tokens) - #;None - #;None - - (#;Some [tokens' a]) - (#;Some [tokens' (f a)]))))) - -(defstruct #export Parser/Monad (M;Monad Parser) - (def M;_functor Parser/Functor) - - (def (M;wrap x tokens) - (#;Some [tokens x])) - - (def (M;join mma) - (lambda [tokens] - (case (mma tokens) - #;None - #;None - - (#;Some [tokens' ma]) - (ma tokens'))))) - -## Parsers -(def #export (id^ tokens) - (Parser Syntax) - (case tokens - #;Nil #;None - (#;Cons [t tokens']) (#;Some [tokens' t]))) - -(do-template [ ] - [(def #export ( tokens) - (Parser ) - (case tokens - (#;Cons [(#;Meta [_ ( x)]) tokens']) - (#;Some [tokens' x]) - - _ - #;None))] - - [ bool^ Bool #;BoolS] - [ int^ Int #;IntS] - [ real^ Real #;RealS] - [ char^ Char #;CharS] - [ text^ Text #;TextS] - [symbol^ Ident #;SymbolS] - [ tag^ Ident #;TagS] - ) - -(do-template [ ] - [(def #export ( tokens) - (Parser Text) - (case tokens - (#;Cons [(#;Meta [_ ( ["" x])]) tokens']) - (#;Some [tokens' x]) - - _ - #;None))] - - [local-symbol^ #;SymbolS] - [ local-tag^ #;TagS] - ) - -(def (ident:= x y) - (-> Ident Ident Bool) - (let [[x1 x2] x - [y1 y2] y] - (and (text:= x1 y1) - (text:= x2 y2)))) - -(do-template [ ] - [(def #export ( v tokens) - (-> (Parser (,))) - (case tokens - (#;Cons [(#;Meta [_ ( x)]) tokens']) - (if ( v x) - (#;Some [tokens' []]) - #;None) - - _ - #;None))] - - [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)] - [ int?^ Int #;IntS i=] - [ real?^ Real #;RealS r=] - [ char?^ Char #;CharS (:: c;Char/Eq E;=)] - [ text?^ Text #;TextS (:: t;Text/Eq E;=)] - [symbol?^ Ident #;SymbolS ident:=] - [ tag?^ Ident #;TagS ident:=] - ) - -(do-template [ ] - [(def #export ( p tokens) - (All [a] - (-> (Parser a) (Parser a))) - (case tokens - (#;Cons [(#;Meta [_ ( form)]) tokens']) - (case (p form) - (#;Some [#;Nil x]) (#;Some [tokens' x]) - _ #;None) - - _ - #;None))] - - [ form^ #;FormS] - [tuple^ #;TupleS] - ) - -(def #export (?^ p tokens) - (All [a] - (-> (Parser a) (Parser (Maybe a)))) - (case (p tokens) - #;None (#;Some [tokens #;None]) - (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)]))) - -(def (run-parser p tokens) - (All [a] - (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a)))) - (p tokens)) - -(def #export (*^ p tokens) - (All [a] - (-> (Parser a) (Parser (List a)))) - (case (p tokens) - #;None (#;Some [tokens (list)]) - (#;Some [tokens' x]) (run-parser (do Parser/Monad - [xs (*^ p)] - (M;wrap (list& x xs))) - tokens'))) - -(def #export (+^ p) - (All [a] - (-> (Parser a) (Parser (List a)))) - (do Parser/Monad - [x p - xs (*^ p)] - (M;wrap (list& x xs)))) - -(def #export (&^ p1 p2) - (All [a b] - (-> (Parser a) (Parser b) (Parser (, a b)))) - (do Parser/Monad - [x1 p1 - x2 p2] - (M;wrap [x1 x2]))) - -(def #export (|^ p1 p2 tokens) - (All [a b] - (-> (Parser a) (Parser b) (Parser (Either b)))) - (case (p1 tokens) - (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) - #;None (run-parser (do Parser/Monad - [x2 p2] - (M;wrap (#;Right x2))) - tokens))) - -(def #export (||^ ps tokens) - (All [a] - (-> (List (Parser a)) (Parser (Maybe a)))) - (case ps - #;Nil #;None - (#;Cons [p ps']) (case (p tokens) - #;None (||^ ps' tokens) - (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)])) - )) - -(def #export (end^ tokens) - (Parser (,)) - (case tokens - #;Nil (#;Some [tokens []]) - _ #;None)) - -## Syntax -(defmacro #export (defsyntax tokens) - (let [[exported? tokens] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) - [true tokens'] - - _ - [false tokens]))] - (case tokens - (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) - body)) - (do Lux/Monad - [names+parsers (M;map% Lux/Monad - (: (-> Syntax (Lux (, Syntax Syntax))) - (lambda [arg] - (case arg - (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) - parser))])) - (M;wrap [(symbol$ var-name) parser]) - - (\ (#;Meta [_ (#;SymbolS var-name)])) - (M;wrap [(symbol$ var-name) (` id^)]) - - _ - (l;fail "Syntax pattern expects 2-tuples or symbols.")))) - args) - g!tokens (gensym "tokens") - g!_ (gensym "_") - #let [names (:: List/Functor (F;map first names+parsers)) - error-msg (text$ (text:++ "Wrong syntax for " name)) - body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body name+parser] - (let [[name parser] name+parser] - (` (_lux_case ((~ parser) (~ g!tokens)) - (#;Some [(~ g!tokens) (~ name)]) - (~ body) - - (~ g!_) - (l;fail (~ error-msg))))))) - body - (reverse names+parsers)) - macro-def (: Syntax - (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) - (~ body'))))]] - (M;wrap (list& macro-def - (if exported? - (list (` (_lux_export (~ (symbol$ ["" name]))))) - (list))))) - - _ - (l;fail "Wrong syntax for defsyntax")))) diff --git a/input/program.lux b/input/program.lux deleted file mode 100644 index 984d8610f..000000000 --- a/input/program.lux +++ /dev/null @@ -1,48 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux (codata (stream #as S)) - (control monoid - functor - monad - lazy - comonad) - (data bool - bounded - char - ## cont - dict - (either #as e) - eq - error - id - io - list - maybe - number - ord - (reader #as r) - show - state - (text #as t) - writer) - (host java) - (meta lux - macro - syntax) - math - )) - -(program args - (case args - #;Nil - (println "Hello, world!") - - (#;Cons [name _]) - (println ($ text:++ "Hello, " name "!")))) diff --git a/source/lux.lux b/source/lux.lux new file mode 100644 index 000000000..50f8f1af2 --- /dev/null +++ b/source/lux.lux @@ -0,0 +1,2784 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +## First things first, must define functions +(_jvm_interface "Function" [] + (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## Basic types +(_lux_def Bool (#DataT "java.lang.Boolean")) +(_lux_export Bool) + +(_lux_def Int (#DataT "java.lang.Long")) +(_lux_export Int) + +(_lux_def Real (#DataT "java.lang.Double")) +(_lux_export Real) + +(_lux_def Char (#DataT "java.lang.Character")) +(_lux_export Char) + +(_lux_def Text (#DataT "java.lang.String")) +(_lux_export Text) + +(_lux_def Unit (#TupleT #Nil)) +(_lux_export Unit) + +(_lux_def Void (#VariantT #Nil)) +(_lux_export Void) + +(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) +(_lux_export Ident) + +## (deftype (List a) +## (| #Nil +## (#Cons (, a (List a))))) +(_lux_def List + (#AllT [(#Some #Nil) "lux;List" "a" + (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] + (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") + (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) + #Nil])]))] + #Nil])]))])) +(_lux_export List) + +## (deftype (Maybe a) +## (| #None +## (#Some a))) +(_lux_def Maybe + (#AllT [(#Some #Nil) "lux;Maybe" "a" + (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] + (#Cons [["lux;Some" (#BoundT "a")] + #Nil])]))])) +(_lux_export Maybe) + +## (deftype #rec Type +## (| (#DataT Text) +## (#TupleT (List Type)) +## (#VariantT (List (, Text Type))) +## (#RecordT (List (, Text Type))) +## (#LambdaT (, Type Type)) +## (#BoundT Text) +## (#VarT Int) +## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) +## (#AppT (, Type Type)))) +(_lux_def Type + (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) + Type + (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) + TypeEnv + (#AppT [(#AllT [(#Some #Nil) "Type" "_" + (#VariantT (#Cons [["lux;DataT" Text] + (#Cons [["lux;TupleT" (#AppT [List Type])] + (#Cons [["lux;VariantT" TypeEnv] + (#Cons [["lux;RecordT" TypeEnv] + (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;BoundT" Text] + (#Cons [["lux;VarT" Int] + (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] + (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;ExT" Int] + #Nil])])])])])])])])])]))]) + Void])))) +(_lux_export Type) + +## (deftype (Bindings k v) +## (& #counter Int +## #mappings (List (, k v)))) +(_lux_def Bindings + (#AllT [(#Some #Nil) "lux;Bindings" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;counter" Int] + (#Cons [["lux;mappings" (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))])] + #Nil])]))])])) +(_lux_export Bindings) + +## (deftype (Env k v) +## (& #name Text +## #inner-closures Int +## #locals (Bindings k v) +## #closure (Bindings k v))) +(_lux_def Env + (#AllT [(#Some #Nil) "lux;Env" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;name" Text] + (#Cons [["lux;inner-closures" Int] + (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + #Nil])])])]))])])) +(_lux_export Env) + +## (deftype Cursor +## (, Text Int Int)) +(_lux_def Cursor + (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) +(_lux_export Cursor) + +## (deftype (Meta m v) +## (| (#Meta (, m v)))) +(_lux_def Meta + (#AllT [(#Some #Nil) "lux;Meta" "m" + (#AllT [#None "" "v" + (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") + (#Cons [(#BoundT "v") + #Nil])]))] + #Nil]))])])) +(_lux_export Meta) + +## (deftype (Syntax' w) +## (| (#BoolS Bool) +## (#IntS Int) +## (#RealS Real) +## (#CharS Char) +## (#TextS Text) +## (#SymbolS (, Text Text)) +## (#TagS (, Text Text)) +## (#FormS (List (w (Syntax' w)))) +## (#TupleS (List (w (Syntax' w)))) +## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) +(_lux_def Syntax' + (_lux_case (#AppT [(#BoundT "w") + (#AppT [(#BoundT "lux;Syntax'") + (#BoundT "w")])]) + Syntax + (_lux_case (#AppT [List Syntax]) + SyntaxList + (#AllT [(#Some #Nil) "lux;Syntax'" "w" + (#VariantT (#Cons [["lux;BoolS" Bool] + (#Cons [["lux;IntS" Int] + (#Cons [["lux;RealS" Real] + (#Cons [["lux;CharS" Char] + (#Cons [["lux;TextS" Text] + (#Cons [["lux;SymbolS" Ident] + (#Cons [["lux;TagS" Ident] + (#Cons [["lux;FormS" SyntaxList] + (#Cons [["lux;TupleS" SyntaxList] + (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] + #Nil]) + ])])])])])])])])]) + )])))) +(_lux_export Syntax') + +## (deftype Syntax +## (Meta Cursor (Syntax' (Meta Cursor)))) +(_lux_def Syntax + (_lux_case (#AppT [Meta Cursor]) + w + (#AppT [w (#AppT [Syntax' w])]))) +(_lux_export Syntax) + +(_lux_def SyntaxList (#AppT [List Syntax])) + +## (deftype (Either l r) +## (| (#Left l) +## (#Right r))) +(_lux_def Either + (#AllT [(#Some #Nil) "lux;Either" "l" + (#AllT [#None "" "r" + (#VariantT (#Cons [["lux;Left" (#BoundT "l")] + (#Cons [["lux;Right" (#BoundT "r")] + #Nil])]))])])) +(_lux_export Either) + +## (deftype (StateE s a) +## (-> s (Either Text (, s a)))) +(_lux_def StateE + (#AllT [(#Some #Nil) "lux;StateE" "s" + (#AllT [#None "" "a" + (#LambdaT [(#BoundT "s") + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [(#BoundT "s") + (#Cons [(#BoundT "a") + #Nil])]))])])])])) + +## (deftype Reader +## (List (Meta Cursor Text))) +(_lux_def Reader + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])])) +(_lux_export Reader) + +## (deftype HostState +## (& #writer (^ org.objectweb.asm.ClassWriter) +## #loader (^ java.net.URLClassLoader) +## #classes (^ clojure.lang.Atom))) +(_lux_def HostState + (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] + (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] + (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] + #Nil])])]))) + +## (deftype (DefData' m) +## (| #TypeD +## (#ValueD Type) +## (#MacroD m) +## (#AliasD Ident))) +(_lux_def DefData' + (#AllT [(#Some #Nil) "lux;DefData'" "" + (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] + (#Cons [["lux;ValueD" Type] + (#Cons [["lux;MacroD" (#BoundT "")] + (#Cons [["lux;AliasD" Ident] + #Nil])])])]))])) +(_lux_export DefData') + +## (deftype LuxVar +## (| (#Local Int) +## (#Global Ident))) +(_lux_def LuxVar + (#VariantT (#Cons [["lux;Local" Int] + (#Cons [["lux;Global" Ident] + #Nil])]))) +(_lux_export LuxVar) + +## (deftype (Module Compiler) +## (& #module-aliases (List (, Text Text)) +## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) +## #imports (List Text) +## )) +(_lux_def Module + (#AllT [(#Some #Nil) "lux;Module" "Compiler" + (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] + (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + SyntaxList])])]) + #Nil])])) + #Nil])]))])] + (#Cons [["lux;imports" (#AppT [List Text])] + #Nil])])]))])) +(_lux_export Module) + +## (deftype #rec Compiler +## (& #source Reader +## #modules (List (, Text (Module Compiler))) +## #envs (List (Env Text (, LuxVar Type))) +## #types (Bindings Int Type) +## #host HostState +## #seed Int +## #eval? Bool)) +(_lux_def Compiler + (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" + (#RecordT (#Cons [["lux;source" Reader] + (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) + #Nil])]))])] + (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] + (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] + (#Cons [["lux;host" HostState] + (#Cons [["lux;seed" Int] + (#Cons [["lux;eval?" Bool] + #Nil])])])])])])]))]) + Void])) +(_lux_export Compiler) + +## (deftype Macro +## (-> (List Syntax) (StateE Compiler (List Syntax)))) +(_lux_def Macro + (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE Compiler]) + SyntaxList])])) +(_lux_export Macro) + +## Base functions & macros +## (def _cursor +## Cursor +## ["" -1 -1]) +(_lux_def _cursor + (_lux_: Cursor ["" -1 -1])) + +## (def (_meta data) +## (-> (Syntax' (Meta Cursor)) Syntax) +## (#Meta [["" -1 -1] data])) +(_lux_def _meta + (_lux_: (#LambdaT [(#AppT [Syntax' + (#AppT [Meta Cursor])]) + Syntax]) + (_lux_lambda _ data + (#Meta [_cursor data])))) + +## (def (return x) +## (All [a] +## (-> a Compiler +## (Either Text (, Compiler a)))) +## ...) +(_lux_def return + (_lux_: (#AllT [(#Some #Nil) "" "a" + (#LambdaT [(#BoundT "a") + (#LambdaT [Compiler + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [Compiler + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ val + (_lux_lambda _ state + (#Right [state val]))))) + +## (def (fail msg) +## (All [a] +## (-> Text Compiler +## (Either Text (, Compiler a)))) +## ...) +(_lux_def fail + (_lux_: (#AllT [(#Some #Nil) "" "a" + (#LambdaT [Text + (#LambdaT [Compiler + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [Compiler + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ msg + (_lux_lambda _ state + (#Left msg))))) + +(_lux_def text$ + (_lux_: (#LambdaT [Text Syntax]) + (_lux_lambda _ text + (_meta (#TextS text))))) + +(_lux_def symbol$ + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#SymbolS ident))))) + +(_lux_def tag$ + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#TagS ident))))) + +(_lux_def form$ + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#FormS tokens))))) + +(_lux_def tuple$ + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#TupleS tokens))))) + +(_lux_def record$ + (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_lambda _ tokens + (_meta (#RecordS tokens))))) + +(_lux_def let' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) + (return (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_case"]) + (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + #Nil])) + + _ + (fail "Wrong syntax for let'"))))) +(_lux_declare-macro let') + +(_lux_def lambda' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS ["" ""])) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) + + (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS self)) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) + + _ + (fail "Wrong syntax for lambda"))))) +(_lux_declare-macro lambda') + +(_lux_def def' + (_lux_: Macro + (lambda' [tokens] + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + #Nil])) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + #Nil])) + + _ + (fail "Wrong syntax for def") + )))) +(_lux_declare-macro def') + +(def' (defmacro tokens) + Macro + (_lux_case tokens + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (#Cons [(form$ (#Cons [name args])) + (#Cons [(symbol$ ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])) + (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])])) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (#Cons [(tag$ ["" "export"]) + (#Cons [(form$ (#Cons [name args])) + (#Cons [(symbol$ ["lux" "Macro"]) + (#Cons [body + #Nil])]) + ])])])) + (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])])) + + _ + (fail "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) + +(defmacro #export (comment tokens) + (return #Nil)) + +(defmacro (->' tokens) + (_lux_case tokens + (#Cons [input (#Cons [output #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil])) + + (#Cons [input (#Cons [output others])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for ->'"))) + +(defmacro (All' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS #Nil)]) + (#Cons [body #Nil])]) + (return (#Cons [body + #Nil])) + + (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) + (#Cons [body #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) + (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) + (#Cons [(_meta (#TextS "")) + (#Cons [(_meta (#TextS arg-name)) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) + (#Cons [(_meta (#TupleS other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for All'"))) + +(defmacro (B' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) + #Nil]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) + (#Cons [(_meta (#TextS bound-name)) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for B'"))) + +(defmacro ($' tokens) + (_lux_case tokens + (#Cons [x #Nil]) + (return tokens) + + (#Cons [x (#Cons [y xs])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) + (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) + #Nil])) + + _ + (fail "Wrong syntax for $'"))) + +(def' (foldL f init xs) + (All' [a b] + (->' (->' (B' a) (B' b) (B' a)) + (B' a) + ($' List (B' b)) + (B' a))) + (_lux_case xs + #Nil + init + + (#Cons [x xs']) + (foldL f (f init x) xs'))) + +(def' (reverse list) + (All' [a] + (->' ($' List (B' a)) ($' List (B' a)))) + (foldL (lambda' [tail head] (#Cons [head tail])) + #Nil + list)) + +(defmacro (list xs) + (return (#Cons [(foldL (lambda' [tail head] + (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) + (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) + (_meta (#TagS ["lux" "Nil"])) + (reverse xs)) + #Nil]))) + +(defmacro (list& xs) + (_lux_case (reverse xs) + (#Cons [last init]) + (return (list (foldL (lambda' [tail head] + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) + last + init))) + + _ + (fail "Wrong syntax for list&"))) + +(defmacro #export (lambda tokens) + (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) + [name tokens'] + + _ + [["" ""] tokens])) + (_lux_case tokens' + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case args + #Nil + (fail "lambda requires a non-empty arguments tuple.") + + (#Cons [harg targs]) + (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ name) + harg + (foldL (lambda' [body' arg] + (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" ""]) + arg + body'))) + body + (reverse targs))))))) + + _ + (fail "Wrong syntax for lambda")))) + +(defmacro (def'' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + (form$ (list (symbol$ ["lux" "lambda"]) + name + (tuple$ args) + body)))))) + (form$ (list (symbol$ ["" "_lux_export"]) name)))) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + body)))) + (form$ (list (symbol$ ["" "_lux_export"]) name)))) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + (form$ (list (symbol$ ["lux" "lambda"]) + name + (tuple$ args) + body)))))))) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) type body)))))) + + _ + (fail "Wrong syntax for def") + )) + +(def'' (as-pairs xs) + (All' [a] + (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) + (_lux_case xs + (#Cons [x (#Cons [y xs'])]) + (#Cons [[x y] (as-pairs xs')]) + + _ + #Nil)) + +(defmacro #export (let tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) + (return (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (_lux_case binding + [label value] + (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) + body + (reverse (as-pairs bindings))))) + + _ + (fail "Wrong syntax for let"))) + +(def'' (map f xs) + (All' [a b] + (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) + (_lux_case xs + #Nil + #Nil + + (#Cons [x xs']) + (#Cons [(f x) (map f xs')]))) + +(def'' (any? p xs) + (All' [a] + (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) + (_lux_case xs + #Nil + false + + (#Cons [x xs']) + (_lux_case (p x) + true true + false (any? p xs')))) + +(def'' (spliced? token) + (->' Syntax Bool) + (_lux_case token + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) + true + + _ + false)) + +(def'' (wrap-meta content) + (->' Syntax Syntax) + (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) + (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) + content))))))) + +(def'' (untemplate-list tokens) + (->' ($' List Syntax) Syntax) + (_lux_case tokens + #Nil + (_meta (#TagS ["lux" "Nil"])) + + (#Cons [token tokens']) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list token (untemplate-list tokens'))))))))) + +(def'' #export (list:++ xs ys) + (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) + (_lux_case xs + (#Cons [x xs']) + (#Cons [x (list:++ xs' ys)]) + + #Nil + ys)) + +(defmacro #export ($ tokens) + (_lux_case tokens + (#Cons [op (#Cons [init args])]) + (return (list (foldL (lambda [a1 a2] (form$ (list op a1 a2))) + init + args))) + + _ + (fail "Wrong syntax for $"))) + +(def'' (splice replace? untemplate tag elems) + (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) + (_lux_case replace? + true + (_lux_case (any? spliced? elems) + true + (let [elems' (map (lambda [elem] + (_lux_case elem + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced + + _ + (form$ (list (symbol$ ["" "_lux_:"]) + (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) + (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) + (tag$ ["lux" "Nil"]))))))))) + elems)] + (wrap-meta (form$ (list tag + (form$ (list& (symbol$ ["lux" "$"]) + (symbol$ ["lux" "list:++"]) + elems')))))) + + false + (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))) + false + (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) + +(def'' (untemplate replace? subst token) + (->' Bool Text Syntax Syntax) + (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token]) + [_ (#Meta [_ (#BoolS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) + + [_ (#Meta [_ (#IntS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) + + [_ (#Meta [_ (#RealS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) + + [_ (#Meta [_ (#CharS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) + + [_ (#Meta [_ (#TextS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) + + [_ (#Meta [_ (#TagS [module name])])] + (let [module' (_lux_case module + "" + subst + + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) + + [_ (#Meta [_ (#SymbolS [module name])])] + (let [module' (_lux_case module + "" + subst + + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) + + [_ (#Meta [_ (#TupleS elems)])] + (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) + + [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] + unquoted + + [_ (#Meta [_ (#FormS elems)])] + (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) + + [_ (#Meta [_ (#RecordS fields)])] + (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) + (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) + (lambda [kv] + (let [[k v] kv] + (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) + fields))))) + )) + +(defmacro (`' tokens) + (_lux_case tokens + (#Cons [template #Nil]) + (return (list (untemplate true "" template))) + + _ + (fail "Wrong syntax for `'"))) + +(defmacro (' tokens) + (_lux_case tokens + (#Cons [template #Nil]) + (return (list (untemplate false "" template))) + + _ + (fail "Wrong syntax for '"))) + +(defmacro #export (|> tokens) + (_lux_case tokens + (#Cons [init apps]) + (return (list (foldL (lambda [acc app] + (_lux_case app + (#Meta [_ (#TupleS parts)]) + (tuple$ (list:++ parts (list acc))) + + (#Meta [_ (#FormS parts)]) + (form$ (list:++ parts (list acc))) + + _ + (`' ((~ app) (~ acc))))) + init + apps))) + + _ + (fail "Wrong syntax for |>"))) + +(defmacro #export (if tokens) + (_lux_case tokens + (#Cons [test (#Cons [then (#Cons [else #Nil])])]) + (return (list (`' (_lux_case (~ test) + true (~ then) + false (~ else))))) + + _ + (fail "Wrong syntax for if"))) + +## (deftype (Lux a) +## (-> Compiler (Either Text (, Compiler a)))) +(def'' #export Lux + Type + (All' [a] + (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) + +## (defsig (Monad m) +## (: (All [a] (-> a (m a))) +## return) +## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) +## bind)) +(def'' Monad + Type + (All' [m] + (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] + ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b))))])))) + +(def'' Maybe/Monad + ($' Monad Maybe) + {#lux;return + (lambda return [x] + (#Some x)) + + #lux;bind + (lambda [f ma] + (_lux_case ma + #None #None + (#Some a) (f a)))}) + +(def'' Lux/Monad + ($' Monad Lux) + {#lux;return + (lambda [x] + (lambda [state] + (#Right [state x]))) + + #lux;bind + (lambda [f ma] + (lambda [state] + (_lux_case (ma state) + (#Left msg) + (#Left msg) + + (#Right [state' a]) + (f a state'))))}) + +(defmacro #export (^ tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) + (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) + + _ + (fail "Wrong syntax for ^"))) + +(defmacro #export (-> tokens) + (_lux_case (reverse tokens) + (#Cons [output inputs]) + (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) + output + inputs))) + + _ + (fail "Wrong syntax for ->"))) + +(defmacro #export (, tokens) + (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) + +(defmacro (do tokens) + (_lux_case tokens + (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) + (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (_lux_case var + (#Meta [_ (#TagS ["" "let"])]) + (`' (;let (~ value) (~ body'))) + + _ + (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) + (~ var) + (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (return (list (`' (_lux_case (~ monad) + {#;return ;return #;bind ;bind} + (~ body')))))) + + _ + (fail "Wrong syntax for do"))) + +(def'' (map% m f xs) + ## (All [m a b] + ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (All' [m a b] + (-> ($' Monad (B' m)) + (-> (B' a) ($' (B' m) (B' b))) + ($' List (B' a)) + ($' (B' m) ($' List (B' b))))) + (let [{#;return ;return #;bind _} m] + (_lux_case xs + #Nil + (;return #Nil) + + (#Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;return (#Cons [y ys]))) + ))) + +(def'' #export (. f g) + (All' [a b c] + (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) + (lambda [x] + (f (g x)))) + +(def'' (get-ident x) + (-> Syntax ($' Maybe Text)) + (_lux_case x + (#Meta [_ (#SymbolS ["" sname])]) + (#Some sname) + + _ + #None)) + +(def'' (tuple->list tuple) + (-> Syntax ($' Maybe ($' List Syntax))) + (_lux_case tuple + (#Meta [_ (#TupleS members)]) + (#Some members) + + _ + #None)) + +(def'' RepEnv + Type + ($' List (, Text Syntax))) + +(def'' (make-env xs ys) + (-> ($' List Text) ($' List Syntax) RepEnv) + (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) + [xs ys]) + [(#Cons [x xs']) (#Cons [y ys'])] + (#Cons [[x y] (make-env xs' ys')]) + + _ + #Nil)) + +(def'' #export (text:= x y) + (-> Text Text Bool) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y])) + +(def'' (get-rep key env) + (-> Text RepEnv ($' Maybe Syntax)) + (_lux_case env + #Nil + #None + + (#Cons [[k v] env']) + (if (text:= k key) + (#Some v) + (get-rep key env')))) + +(def'' (apply-template env template) + (-> RepEnv Syntax Syntax) + (_lux_case template + (#Meta [_ (#SymbolS ["" sname])]) + (_lux_case (get-rep sname env) + (#Some subst) + subst + + _ + template) + + (#Meta [_ (#TupleS elems)]) + (tuple$ (map (apply-template env) elems)) + + (#Meta [_ (#FormS elems)]) + (form$ (map (apply-template env) elems)) + + (#Meta [_ (#RecordS members)]) + (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [kv] + (let [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) + members)) + + _ + template)) + +(def'' (join-map f xs) + (All' [a b] + (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) + (_lux_case xs + #Nil + #Nil + + (#Cons [x xs']) + (list:++ (f x) (join-map f xs')))) + +(defmacro #export (do-template tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) + (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) + [(map% Maybe/Monad get-ident bindings) + (map% Maybe/Monad tuple->list data)]) + [(#Some bindings') (#Some data')] + (let [apply (_lux_: (-> RepEnv ($' List Syntax)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + return)) + + _ + (fail "Wrong syntax for do-template")) + + _ + (fail "Wrong syntax for do-template"))) + +(do-template [ ] + [(def'' #export ( x y) + (-> Bool) + ( x y))] + + [i= _jvm_leq Int] + [i> _jvm_lgt Int] + [i< _jvm_llt Int] + [r= _jvm_deq Real] + [r> _jvm_dgt Real] + [r< _jvm_dlt Real] + ) + +(do-template [ ] + [(def'' #export ( x y) + (-> Bool) + (if ( x y) + true + ( x y)))] + + [i>= i> i= Int] + [i<= i< i= Int] + [r>= r> r= Real] + [r<= r< r= Real] + ) + +(do-template [ ] + [(def'' #export ( x y) + (-> ) + ( x y))] + + [i+ _jvm_ladd Int] + [i- _jvm_lsub Int] + [i* _jvm_lmul Int] + [i/ _jvm_ldiv Int] + [i% _jvm_lrem Int] + [r+ _jvm_dadd Real] + [r- _jvm_dsub Real] + [r* _jvm_dmul Real] + [r/ _jvm_ddiv Real] + [r% _jvm_drem Real] + ) + +(def'' (multiple? div n) + (-> Int Int Bool) + (i= 0 (i% n div))) + +(def'' (length list) + (-> List Int) + (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) + +(def'' #export (not x) + (-> Bool Bool) + (if x false true)) + +(def'' #export (text:++ x y) + (-> Text Text Text) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y])) + +(def'' (ident->text ident) + (-> Ident Text) + (let [[module name] ident] + ($ text:++ module ";" name))) + +(def'' (replace-syntax reps syntax) + (-> RepEnv Syntax Syntax) + (_lux_case syntax + (#Meta [_ (#SymbolS ["" name])]) + (_lux_case (get-rep name reps) + (#Some replacement) + replacement + + #None + syntax) + + (#Meta [_ (#FormS parts)]) + (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) + + (#Meta [_ (#TupleS members)]) + (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) + + (#Meta [_ (#RecordS slots)]) + (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[k v] slot] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))]) + + _ + syntax) + ) + +(defmacro #export (All tokens) + (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) + [self-ident tokens'] + + _ + ["" tokens]))] + (_lux_case tokens' + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case (map% Maybe/Monad get-ident args) + (#Some idents) + (_lux_case idents + #Nil + (return (list body)) + + (#Cons [harg targs]) + (let [replacements (map (_lux_: (-> Text (, Text Syntax)) + (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) + (list& self-ident idents)) + body' (foldL (lambda [body' arg'] + (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) + (replace-syntax replacements body) + (reverse targs))] + ## (#;Some #;Nil) + (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) + + #None + (fail "'All' arguments must be symbols.")) + + _ + (fail "Wrong syntax for All")) + )) + +(def'' (get k plist) + (All [a] + (-> Text ($' List (, Text a)) ($' Maybe a))) + (_lux_case plist + (#Cons [[k' v] plist']) + (if (text:= k k') + (#Some v) + (get k plist')) + + #Nil + #None)) + +(def'' (put k v dict) + (All [a] + (-> Text a ($' List (, Text a)) ($' List (, Text a)))) + (_lux_case dict + #Nil + (list [k v]) + + (#Cons [[k' v'] dict']) + (if (text:= k k') + (#Cons [[k' v] dict']) + (#Cons [[k' v'] (put k v dict')])))) + +(def'' (get-module-name state) + ($' Lux Text) + (_lux_case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (_lux_case (reverse envs) + #Nil + (#Left "Can't get the module name without a module!") + + (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Right [state module-name])))) + +(def'' (find-macro' modules current-module module name) + (-> ($' List (, Text ($' Module Compiler))) + Text Text Text + ($' Maybe Macro)) + (do Maybe/Monad + [$module (get module modules) + gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] + (get name bindings))] + (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) + [exported? (#MacroD macro')] + (if exported? + (#Some macro') + (if (text:= module current-module) + (#Some macro') + #None)) + + [_ (#AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #None))) + +(def'' (find-macro ident) + (-> Ident ($' Lux ($' Maybe Macro))) + (do Lux/Monad + [current-module get-module-name] + (let [[module name] ident] + (lambda [state] + (_lux_case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (#Right [state (find-macro' modules current-module module name)])))))) + +(def'' (list:join xs) + (All [a] + (-> ($' List ($' List a)) ($' List a))) + (foldL list:++ #Nil xs)) + +(def'' (normalize ident) + (-> Ident ($' Lux Ident)) + (_lux_case ident + ["" name] + (do Lux/Monad + [module-name get-module-name] + (;return (_lux_: Ident [module-name name]))) + + _ + (return ident))) + +(defmacro #export (| tokens) + (do Lux/Monad + [pairs (map% Lux/Monad + (_lux_: (-> Syntax ($' Lux Syntax)) + (lambda [token] + (_lux_case token + (#Meta [_ (#TagS ident)]) + (do Lux/Monad + [ident (normalize ident)] + (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) + + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) + (do Lux/Monad + [ident (normalize ident)] + (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) + + _ + (fail "Wrong syntax for |")))) + tokens)] + (;return (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) + +(defmacro #export (& tokens) + (if (not (multiple? 2 (length tokens))) + (fail "& expects an even number of arguments.") + (do Lux/Monad + [pairs (map% Lux/Monad + (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) + (lambda [pair] + (_lux_case pair + [(#Meta [_ (#TagS ident)]) value] + (do Lux/Monad + [ident (normalize ident)] + (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) + + _ + (fail "Wrong syntax for &")))) + (as-pairs tokens))] + (;return (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) + +(def'' #export (->text x) + (-> (^ java.lang.Object) Text) + (_jvm_invokevirtual java.lang.Object toString [] x [])) + +(def'' (interpose sep xs) + (All [a] + (-> a ($' List a) ($' List a))) + (_lux_case xs + #Nil + xs + + (#Cons [x #Nil]) + xs + + (#Cons [x xs']) + (list& x sep (interpose sep xs')))) + +(def'' (macro-expand syntax) + (-> Syntax ($' Lux ($' List Syntax))) + (_lux_case syntax + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Lux/Monad + [expansion (macro args) + expansion' (map% Lux/Monad macro-expand expansion)] + (;return (list:join expansion'))) + + #None + (do Lux/Monad + [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] + (;return (list (form$ (list:join parts'))))))) + + (#Meta [_ (#FormS (#Cons [harg targs]))]) + (do Lux/Monad + [harg+ (macro-expand harg) + targs+ (map% Lux/Monad macro-expand targs)] + (;return (list (form$ (list:++ harg+ (list:join targs+)))))) + + (#Meta [_ (#TupleS members)]) + (do Lux/Monad + [members' (map% Lux/Monad macro-expand members)] + (;return (list (tuple$ (list:join members'))))) + + _ + (return (list syntax)))) + +(def'' (walk-type type) + (-> Syntax Syntax) + (_lux_case type + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + (form$ (#Cons [(tag$ tag) (map walk-type parts)])) + + (#Meta [_ (#TupleS members)]) + (tuple$ (map walk-type members)) + + (#Meta [_ (#FormS (#Cons [type-fn args]))]) + (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) + (walk-type type-fn) + (map walk-type args)) + + _ + type)) + +(defmacro #export (type tokens) + (_lux_case tokens + (#Cons [type #Nil]) + (do Lux/Monad + [type+ (macro-expand type)] + (_lux_case type+ + (#Cons [type' #Nil]) + (;return (list (walk-type type'))) + + _ + (fail "The expansion of the type-syntax had to yield a single element."))) + + _ + (fail "Wrong syntax for type"))) + +(defmacro #export (: tokens) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (list (`' (_lux_: (;type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :"))) + +(defmacro #export (:! tokens) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (list (`' (_lux_:! (;type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :!"))) + +(def'' (empty? xs) + (All [a] (-> ($' List a) Bool)) + (_lux_case xs + #Nil true + _ false)) + +(defmacro #export (deftype tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + [rec? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) + [true tokens'] + + _ + [false tokens'])) + parts (: (Maybe (, Text (List Syntax) Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) + (#Some [name #Nil type]) + + (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) + (#Some [name args type]) + + _ + #None))] + (_lux_case parts + (#Some [name args type]) + (let [with-export (: (List Syntax) + (if export? + (list (`' (_lux_export (~ (symbol$ ["" name]))))) + #Nil)) + type' (: (Maybe Syntax) + (if rec? + (if (empty? args) + (let [g!param (symbol$ ["" ""]) + prime-name (symbol$ ["" (text:++ name "'")]) + type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] + (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) + ;Void)))) + #None) + (_lux_case args + #Nil + (#Some type) + + _ + (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] + (_lux_case type' + (#Some type'') + (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) + with-export)) + + #None + (fail "Wrong syntax for deftype"))) + + #None + (fail "Wrong syntax for deftype")) + )) +## (defmacro #export (deftype tokens) +## (let [[export? tokens'] (: (, Bool (List Syntax)) +## (_lux_case (:! (List Syntax) tokens) +## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) +## [true (:! (List Syntax) tokens')] + +## _ +## [false (:! (List Syntax) tokens)])) +## parts (: (Maybe (, Syntax (List Syntax) Syntax)) +## (_lux_case tokens' +## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) +## (#Some [(symbol$ name) #Nil type]) + +## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) +## (#Some [(symbol$ name) args type]) + +## _ +## #None))] +## (_lux_case parts +## (#Some [name args type]) +## (let [with-export (: (List Syntax) +## (if export? +## (list (`' (_lux_export (~ name)))) +## #Nil)) +## type' (: Syntax +## (_lux_case args +## #Nil +## type + +## _ +## (`' (;All (~ name) [(~@ args)] (~ type)))))] +## (return (list& (`' (_lux_def (~ name) (;type (~ type')))) +## with-export))) + +## #None +## (fail "Wrong syntax for deftype")) +## )) + +(defmacro #export (exec tokens) + (_lux_case (reverse tokens) + (#Cons [value actions]) + (let [dummy (symbol$ ["" ""])] + (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) + value + actions)))) + + _ + (fail "Wrong syntax for exec"))) + +(defmacro #export (def tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) + (#Some [name args (#Some type) body]) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (#Some [name #Nil (#Some type) body]) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Some [name args #None body]) + + (#Cons [name (#Cons [body #Nil])]) + (#Some [name #Nil #None body]) + + _ + #None))] + (_lux_case parts + (#Some [name args ?type body]) + (let [body' (: Syntax + (_lux_case args + #Nil + body + + _ + (`' (;lambda (~ name) [(~@ args)] (~ body))))) + body'' (: Syntax + (_lux_case ?type + (#Some type) + (`' (: (~ type) (~ body'))) + + #None + body'))] + (return (list& (`' (_lux_def (~ name) (~ body''))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) + + #None + (fail "Wrong syntax for def")))) + +(def (rejoin-pair pair) + (-> (, Syntax Syntax) (List Syntax)) + (let [[left right] pair] + (list left right))) + +(defmacro #export (case tokens) + (_lux_case tokens + (#Cons [value branches]) + (do Lux/Monad + [expansions (map% Lux/Monad + (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) + (lambda expander [branch] + (let [[pattern body] branch] + (_lux_case pattern + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) + (do Lux/Monad + [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) + expansions (map% Lux/Monad expander (as-pairs expansion))] + (;return (list:join expansions))) + + _ + (;return (list branch)))))) + (as-pairs branches))] + (;return (list (`' (_lux_case (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) + + _ + (fail "Wrong syntax for case"))) + +(defmacro #export (\ tokens) + (case tokens + (#Cons [body (#Cons [pattern #Nil])]) + (do Lux/Monad + [pattern+ (macro-expand pattern)] + (case pattern+ + (#Cons [pattern' #Nil]) + (;return (list pattern' body)) + + _ + (fail "\\ can only expand to 1 pattern."))) + + _ + (fail "Wrong syntax for \\"))) + +(defmacro #export (\or tokens) + (case tokens + (#Cons [body patterns]) + (case patterns + #Nil + (fail "\\or can't have 0 patterns") + + _ + (do Lux/Monad + [patterns' (map% Lux/Monad macro-expand patterns)] + (;return (list:join (map (lambda [pattern] (list pattern body)) + (list:join patterns')))))) + + _ + (fail "Wrong syntax for \\or"))) + +(do-template [ ] + [(def #export (i+ ))] + + [inc 1] + [dec -1]) + +(defmacro #export (` tokens) + (do Lux/Monad + [module-name get-module-name] + (case tokens + (\ (list template)) + (;return (list (untemplate true module-name template))) + + _ + (fail "Wrong syntax for `")))) + +(def (gensym prefix state) + (-> Text (Lux Syntax)) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (#Right [{#source source #modules modules + #envs envs #types types #host host + #seed (inc seed) #eval? eval?} + (symbol$ ["__gensym__" (->text seed)])]))) + +(def (macro-expand-1 token) + (-> Syntax (Lux Syntax)) + (do Lux/Monad + [token+ (macro-expand token)] + (case token+ + (\ (list token')) + (;return token') + + _ + (fail "Macro expanded to more than 1 element.")))) + +(defmacro #export (sig tokens) + (do Lux/Monad + [tokens' (map% Lux/Monad macro-expand tokens) + members (map% Lux/Monad + (: (-> Syntax (Lux (, Ident Syntax))) + (lambda [token] + (case token + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) + (do Lux/Monad + [name' (normalize name)] + (;return (: (, Ident Syntax) [name' type]))) + + _ + (fail "Signatures require typed members!")))) + (list:join tokens'))] + (;return (list (`' (#;RecordT (~ (untemplate-list (map (: (-> (, Ident Syntax) Syntax) + (lambda [pair] + (let [[name type] pair] + (`' [(~ (|> name ident->text text$)) + (~ type)])))) + members))))))))) + +(defmacro #export (defsig tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens])) + ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) + (case tokens' + (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) + (#Some [name args sigs]) + + (\ (list& name sigs)) + (#Some [name #Nil sigs]) + + _ + #None))] + (case ?parts + (#Some [name args sigs]) + (let [sigs' (: Syntax + (case args + #Nil + (`' (;sig (~@ sigs))) + + _ + (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] + (return (list& (`' (_lux_def (~ name) (~ sigs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) + + #None + (fail "Wrong syntax for defsig")))) + +(defmacro #export (struct tokens) + (do Lux/Monad + [tokens' (map% Lux/Monad macro-expand tokens) + members (map% Lux/Monad + (: (-> Syntax (Lux (, Syntax Syntax))) + (lambda [token] + (case token + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) + (do Lux/Monad + [name' (normalize name)] + (;return (: (, Syntax Syntax) [(tag$ name') value]))) + + _ + (fail "Structures require defined members!")))) + (list:join tokens'))] + (;return (list (record$ members))))) + +(defmacro #export (defstruct tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens])) + ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) + (case tokens' + (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) + (#Some [name args type defs]) + + (\ (list& name type defs)) + (#Some [name #Nil type defs]) + + _ + #None))] + (case ?parts + (#Some [name args type defs]) + (let [defs' (: Syntax + (case args + #Nil + (`' (;struct (~@ defs))) + + _ + (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] + (return (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) + + #None + (fail "Wrong syntax for defstruct")))) + +(def #export (id x) + (All [a] (-> a a)) + x) + +(do-template [ ] + [(defmacro #export ( tokens) + (case (reverse tokens) + (\ (list& last init)) + (return (list (foldL (lambda [post pre] (` )) + last + init))) + + _ + (fail )))] + + [and (if (~ pre) (~ post) false) "and requires >=1 clauses."] + [or (if (~ pre) true (~ post)) "or requires >=1 clauses."]) + +(deftype Referrals + (| #All + (#Only (List Text)) + (#Exclude (List Text)) + #Nothing)) + +(deftype Import + (, Text (Maybe Text) Referrals)) + +(def (extract-defs defs) + (-> (List Syntax) (Lux (List Text))) + (map% Lux/Monad + (: (-> Syntax (Lux Text)) + (lambda [def] + (case def + (#Meta [_ (#SymbolS ["" name])]) + (return name) + + _ + (fail "only/exclude requires symbols.")))) + defs)) + +(def (parse-alias tokens) + (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax)))) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens')) + (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens'])) + + _ + (return (: (, (Maybe Text) (List Syntax)) [#None tokens])))) + +(def (parse-referrals tokens) + (-> (List Syntax) (Lux (, Referrals (List Syntax)))) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens')) + (case referral + (#Meta [_ (#TagS ["" "all"])]) + (return (: (, Referrals (List Syntax)) [#All tokens'])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))])) + (do Lux/Monad + [defs' (extract-defs defs)] + (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "exclude"])]) defs))])) + (do Lux/Monad + [defs' (extract-defs defs)] + (return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens']))) + + _ + (fail "Incorrect syntax for referral.")) + + _ + (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) + +(def (decorate-imports super-name tokens) + (-> Text (List Syntax) (Lux (List Syntax))) + (map% Lux/Monad + (: (-> Syntax (Lux Syntax)) + (lambda [token] + (case token + (#Meta [_ (#SymbolS ["" sub-name])]) + (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))])) + (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) + + _ + (fail "Wrong import syntax.")))) + tokens)) + +(def (parse-imports imports) + (-> (List Syntax) (Lux (List Import))) + (do Lux/Monad + [referrals' (map% Lux/Monad + (: (-> Syntax (Lux (List Import))) + (lambda [token] + (case token + (#Meta [_ (#SymbolS ["" m-name])]) + (;return (list [m-name #None #All])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) + (do Lux/Monad + [alias+extra' (parse-alias extra) + #let [[alias extra'] (: (, (Maybe Text) (List Syntax)) + alias+extra')] + referral+extra'' (parse-referrals extra') + #let [[referral extra''] (: (, Referrals (List Syntax)) + referral+extra'')] + extra''' (decorate-imports m-name extra'') + sub-imports (parse-imports extra''')] + (;return (case referral + #Nothing (case alias + #None sub-imports + (#Some _) (list& [m-name alias referral] sub-imports)) + _ (list& [m-name alias referral] sub-imports)))) + + _ + (fail "Wrong syntax for import")))) + imports)] + (;return (list:join referrals')))) + +(def (module-exists? module state) + (-> Text (Lux Bool)) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (case (get module modules) + (#Some =module) + (#Right [state true]) + + #None + (#Right [state false])) + )) + +(def (exported-defs module state) + (-> Text (Lux (List Text))) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (case (get module modules) + (#Some =module) + (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) + (List Text)) + (lambda [gdef] + (let [[name [export? _]] gdef] + (if export? + (list name) + (list))))) + (let [{#module-aliases _ #defs defs #imports _} =module] + defs))] + (#Right [state (list:join to-alias)])) + + #None + (#Left ($ text:++ "Unknown module: " module))) + )) + +(def (last-index-of part text) + (-> Text Text Int) + (_jvm_i2l (_jvm_invokevirtual java.lang.String lastIndexOf [java.lang.String] + text [part]))) + +(def (index-of part text) + (-> Text Text Int) + (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String] + text [part]))) + +(def (substring1 idx text) + (-> Int Text Text) + (_jvm_invokevirtual java.lang.String substring [int] + text [(_jvm_l2i idx)])) + +(def (substring2 idx1 idx2 text) + (-> Int Int Text Text) + (_jvm_invokevirtual java.lang.String substring [int int] + text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) + +(def (split-module-contexts module) + (-> Text (List Text)) + (#Cons [module (let [idx (last-index-of "/" module)] + (if (i< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module))))])) + +(def (split-module module) + (-> Text (List Text)) + (let [idx (index-of "/" module)] + (if (i< idx 0) + (#Cons [module #Nil]) + (#Cons [(substring2 0 idx module) + (split-module (substring1 (inc idx) module))])))) + +(def (@ idx xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons [x xs']) + (if (i= idx 0) + (#Some x) + (@ (dec idx) xs') + ))) + +(def (split-with' p ys xs) + (All [a] + (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) + (case xs + #Nil + [ys xs] + + (#Cons [x xs']) + (if (p x) + (split-with' p (list& x ys) xs') + [ys xs]))) + +(def (split-with p xs) + (All [a] + (-> (-> a Bool) (List a) (, (List a) (List a)))) + (let [[ys' xs'] (split-with' p #Nil xs)] + [(reverse ys') xs'])) + +(def (clean-module module) + (-> Text (Lux Text)) + (do Lux/Monad + [module-name get-module-name] + (case (split-module module) + (\ (list& "." parts)) + (return (|> (list& module-name parts) (interpose "/") (foldL text:++ ""))) + + parts + (let [[ups parts'] (split-with (text:= "..") parts) + num-ups (length ups)] + (if (i= num-ups 0) + (return module) + (case (@ num-ups (split-module-contexts module-name)) + #None + (fail (text:++ "Can't clean module: " module)) + + (#Some top-module) + (return (|> (list& top-module parts') (interpose "/") (foldL text:++ "")))) + ))) + )) + +(def (filter p xs) + (All [a] (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + (list) + + (#;Cons [x xs']) + (if (p x) + (#;Cons [x (filter p xs')]) + (filter p xs')))) + +(def (is-member? cases name) + (-> (List Text) Text Bool) + (let [output (foldL (lambda [prev case] + (or prev + (text:= case name))) + false + cases)] + output)) + +(defmacro #export (import tokens) + (do Lux/Monad + [imports (parse-imports tokens) + imports (map% Lux/Monad + (: (-> Import (Lux Import)) + (lambda [import] + (case import + [m-name m-alias m-referrals] + (do Lux/Monad + [m-name (clean-module m-name)] + (;return (: Import [m-name m-alias m-referrals])))))) + imports) + unknowns' (map% Lux/Monad + (: (-> Import (Lux (List Text))) + (lambda [import] + (case import + [m-name _ _] + (do Lux/Monad + [? (module-exists? m-name)] + (;return (if ? + (list) + (list m-name))))))) + imports) + #let [unknowns (list:join unknowns')]] + (case unknowns + #Nil + (do Lux/Monad + [output' (map% Lux/Monad + (: (-> Import (Lux (List Syntax))) + (lambda [import] + (case import + [m-name m-alias m-referrals] + (do Lux/Monad + [defs (case m-referrals + #All + (exported-defs m-name) + + (#Only +defs) + (do Lux/Monad + [*defs (exported-defs m-name)] + (;return (filter (is-member? +defs) *defs))) + + (#Exclude -defs) + (do Lux/Monad + [*defs (exported-defs m-name)] + (;return (filter (. not (is-member? -defs)) *defs))) + + #Nothing + (;return (list)))] + (;return ($ list:++ + (list (` (_lux_import (~ (text$ m-name))))) + (case m-alias + #None (list) + (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) + (map (: (-> Text Syntax) + (lambda [def] + (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) + defs))))))) + imports)] + (;return (list:join output'))) + + _ + (;return (: (List Syntax) + (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) + unknowns) + (list (` (import (~@ tokens)))))))))) + +(def (some f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #Nil + #None + + (#Cons [x xs']) + (case (f x) + #None + (some f xs') + + (#Some y) + (#Some y)))) + +(def (split-slot slot) + (-> Text (, Text Text)) + (let [idx (index-of ";" slot) + module (substring2 0 idx slot) + name (substring1 (inc idx) slot)] + [module name])) + +(def (type:show type) + (-> Type Text) + (case type + (#DataT name) + ($ text:++ "(^ " name ")") + + (#TupleT elems) + (case elems + #;Nil + "(,)" + + _ + ($ text:++ "(, " (|> elems (map type:show) (interpose " ") (foldL text:++ "")) ")")) + + (#VariantT cases) + (case cases + #;Nil + "(|)" + + _ + ($ text:++ "(| " + (|> cases + (map (: (-> (, Text Type) Text) + (lambda [kv] + (case kv + [k (#TupleT #;Nil)] + ($ text:++ "#" k) + + [k v] + ($ text:++ "(#" k " " (type:show v) ")"))))) + (interpose " ") + (foldL text:++ "")) + ")")) + + (#RecordT fields) + (case fields + #;Nil + "(&)" + + _ + ($ text:++ "(& " + (|> fields + (map (: (-> (, Text Type) Text) + (: (-> (, Text Type) Text) + (lambda [kv] + (let [[k v] kv] + ($ text:++ "(#" k " " (type:show v) ")")))))) + (interpose " ") + (foldL text:++ "")) + ")")) + + (#LambdaT [input output]) + ($ text:++ "(-> " (type:show input) " " (type:show output) ")") + + (#VarT id) + ($ text:++ "⌈" (->text id) "⌋") + + (#BoundT name) + name + + (#ExT ?id) + ($ text:++ "⟨" (->text ?id) "⟩") + + (#AppT [?lambda ?param]) + ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")") + + (#AllT [?env ?name ?arg ?body]) + ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")") + )) + +(def (beta-reduce env type) + (-> (List (, Text Type)) Type Type) + (case type + (#VariantT ?cases) + (#VariantT (map (: (-> (, Text Type) (, Text Type)) + (lambda [kv] + (let [[k v] kv] + [k (beta-reduce env v)]))) + ?cases)) + + (#RecordT ?fields) + (#RecordT (map (: (-> (, Text Type) (, Text Type)) + (lambda [kv] + (let [[k v] kv] + [k (beta-reduce env v)]))) + ?fields)) + + (#TupleT ?members) + (#TupleT (map (beta-reduce env) ?members)) + + (#AppT [?type-fn ?type-arg]) + (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)]) + + (#AllT [?local-env ?local-name ?local-arg ?local-def]) + (case ?local-env + #None + (#AllT [(#Some env) ?local-name ?local-arg ?local-def]) + + (#Some _) + type) + + (#LambdaT [?input ?output]) + (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)]) + + (#BoundT ?name) + (case (get ?name env) + (#Some bound) + bound + + _ + type) + + _ + type + )) + +(defmacro #export (? tokens) + (case tokens + (\ (list maybe else)) + (do Lux/Monad + [g!value (gensym "")] + (return (list (` (case (~ maybe) + (#;Some (~ g!value)) + (~ g!value) + + _ + (~ else)))))) + + _ + (fail "Wrong syntax for ?"))) + +(def (apply-type type-fn param) + (-> Type Type (Maybe Type)) + (case type-fn + (#AllT [env name arg body]) + (#Some (beta-reduce (|> (? env (list)) + (put name type-fn) + (put arg param)) + body)) + + (#AppT [F A]) + (do Maybe/Monad + [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + _ + #None)) + +(def (resolve-struct-type type) + (-> Type (Maybe Type)) + (case type + (#RecordT slots) + (#Some type) + + (#AppT [fun arg]) + (apply-type fun arg) + + (#AllT [_ _ _ body]) + (resolve-struct-type body) + + _ + #None)) + +(def (try-both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #;None (f x2) + (#;Some y) (#;Some y))) + +(def (find-in-env name state) + (-> Ident Compiler (Maybe Type)) + (let [vname' (ident->text name)] + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (lambda [env] + (case env + {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} + (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= vname' bname) + (#Some type) + #None))))) + locals + closure)))) + envs)))) + +(def (show-envs envs) + (-> (List (Env Text (, LuxVar Type))) Text) + (|> envs + (map (lambda [env] + (case env + {#name name #inner-closures _ #locals {#counter _ #mappings locals} #closure _} + ($ text:++ name ": " (|> locals + (map (: (All [a] (-> (, Text a) Text)) + (lambda [b] (let [[label _] b] label)))) + (interpose " ") + (foldL text:++ "")))))) + (interpose "\n") + (foldL text:++ ""))) + +(def (find-in-defs name state) + (-> Ident Compiler (Maybe Type)) + (let [[v-prefix v-name] name + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} state] + (case (get v-prefix modules) + #None + #None + + (#Some {#defs defs #module-aliases _ #imports _}) + (case (get v-name defs) + #None + #None + + (#Some [_ def-data]) + (case def-data + #TypeD (#Some Type) + (#ValueD type) (#Some type) + (#MacroD m) (#Some Macro) + (#AliasD name') (find-in-defs name' state)))))) +## (def (find-in-defs name state) +## (-> Ident Compiler (Maybe Type)) +## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] +## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-defs #1: " (ident->text name) "\n")]) +## (let [[v-prefix v-name] name +## {#source source #modules modules +## #envs envs #types types #host host +## #seed seed #eval? eval?} state] +## (do Maybe/Monad +## [module (get v-prefix modules) +## #let [{#defs defs #module-aliases _ #imports _} module] +## def (get v-name defs) +## #let [[_ def-data] def]] +## (case def-data +## #TypeD (;return Type) +## (#ValueD type) (;return type) +## (#MacroD m) (;return Macro) +## (#AliasD name') (find-in-defs name' state)))))) + +(def (find-var-type name) + (-> Ident (Lux Type)) + (do Lux/Monad + [name' (normalize name)] + (lambda [state] + (case (find-in-env name state) + (#Some struct-type) + (#Right [state struct-type]) + + _ + (case (find-in-defs name' state) + (#Some struct-type) + (#Right [state struct-type]) + + _ + (let [{#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} state] + (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) + +(defmacro #export (using tokens) + (case tokens + (\ (list struct body)) + (case struct + (#Meta [_ (#SymbolS name)]) + (do Lux/Monad + [struct-type (find-var-type name)] + (case (resolve-struct-type struct-type) + (#Some (#RecordT slots)) + (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + (lambda [slot] + (let [[sname stype] slot + full-name (split-slot sname)] + [(tag$ full-name) (symbol$ full-name)]))) + slots))] + (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) + + _ + (fail "Can only \"use\" records."))) + + _ + (let [dummy (symbol$ ["" ""])] + (return (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) + (~ body)))))))) + + _ + (fail "Wrong syntax for using"))) + +(def #export (flip f) + (All [a b c] + (-> (-> a b c) (-> b a c))) + (lambda [y x] + (f x y))) + +(def #export (curry f) + (All [a b c] + (-> (-> (, a b) c) + (-> a b c))) + (lambda [x y] + (f [x y]))) + +(def #export (uncurry f) + (All [a b c] + (-> (-> a b c) + (-> (, a b) c))) + (lambda [xy] + (let [[x y] xy] + (f x y)))) + +(defmacro #export (cond tokens) + (if (i= 0 (i% (length tokens) 2)) + (fail "cond requires an even number of arguments.") + (case (reverse tokens) + (\ (list& else branches')) + (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [else branch] + (let [[right left] branch] + (` (if (~ left) (~ right) (~ else)))))) + else + (as-pairs branches')))) + + _ + (fail "Wrong syntax for cond")))) + +(defmacro #export (get@ tokens) + (case tokens + (\ (list (#Meta [_ (#TagS slot')]) record)) + (case record + (#Meta [_ (#SymbolS name)]) + (do Lux/Monad + [type (find-var-type name) + g!blank (gensym "") + g!output (gensym "")] + (case (resolve-struct-type type) + (#Some (#RecordT slots)) + (do Lux/Monad + [slot (normalize slot')] + (let [[s-prefix s-name] (: Ident slot) + pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-type] slot + [r-prefix r-name] (split-slot r-slot-name)] + [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) + (text:= s-name r-name)) + g!output + g!blank)]))) + slots))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output))))))) + + _ + (fail "get@ can only use records."))) + + _ + (do Lux/Monad + [_record (gensym "")] + (return (list (` (let [(~ _record) (~ record)] + (get@ (~ (tag$ slot')) (~ _record)))))))) + + _ + (fail "Wrong syntax for get@"))) + +(defmacro #export (open tokens) + (case tokens + (\ (list (#Meta [_ (#SymbolS struct-name)]))) + (do Lux/Monad + [struct-type (find-var-type struct-name)] + (case (resolve-struct-type struct-type) + (#Some (#RecordT slots)) + (return (map (: (-> (, Text Type) Syntax) + (lambda [slot] + (let [[sname stype] slot + [module name] (split-slot sname)] + (` (_lux_def (~ (symbol$ ["" name])) + (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name)))))))) + slots)) + + _ + (fail "Can only \"open\" records."))) + + _ + (fail "Wrong syntax for open"))) + +(def (foldL% M f x ys) + (All [m a b] + (-> (Monad m) (-> a b (m a)) a (List b) + (m a))) + (case ys + (#Cons [y ys']) + (do M + [x' (f x y)] + (foldL% M f x' ys')) + + #Nil + ((get@ #return M) x))) + +(defmacro #export (:: tokens) + (case tokens + (\ (list& start parts)) + (do Lux/Monad + [output (foldL% Lux/Monad + (: (-> Syntax Syntax (Lux Syntax)) + (lambda [so-far part] + (case part + (#Meta [_ (#SymbolS slot)]) + (return (` (get@ (~ (tag$ slot)) (~ so-far)))) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))])) + (return (` ((get@ (~ (tag$ slot)) (~ so-far)) + (~@ args)))) + + _ + (fail "Wrong syntax for ::")))) + start parts)] + (return (list output))) + + _ + (fail "Wrong syntax for ::"))) + +(defmacro #export (set@ tokens) + (case tokens + (\ (list (#Meta [_ (#TagS slot')]) value record)) + (case record + (#Meta [_ (#SymbolS name)]) + (do Lux/Monad + [type (find-var-type name)] + (case (resolve-struct-type type) + (#Some (#RecordT slots)) + (do Lux/Monad + [pattern' (map% Lux/Monad + (: (-> (, Text Type) (Lux (, Text Syntax))) + (lambda [slot] + (let [[r-slot-name r-type] slot] + (do Lux/Monad + [g!slot (gensym "")] + (return [r-slot-name g!slot]))))) + slots) + slot (normalize slot')] + (let [[s-prefix s-name] (: Ident slot) + pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-var] slot] + [(tag$ (split-slot r-slot-name)) r-var]))) + pattern')) + output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-var] slot + [r-prefix r-name] (split-slot r-slot-name)] + [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) + (text:= s-name r-name)) + value + r-var)]))) + pattern'))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + + _ + (fail "set@ can only use records."))) + + _ + (do Lux/Monad + [_record (gensym "")] + (return (list (` (let [(~ _record) (~ record)] + (set@ (~ (tag$ slot')) (~ value) (~ _record)))))))) + + _ + (fail "Wrong syntax for set@"))) + +(defmacro #export (update@ tokens) + (case tokens + (\ (list (#Meta [_ (#TagS slot')]) fun record)) + (case record + (#Meta [_ (#SymbolS name)]) + (do Lux/Monad + [type (find-var-type name)] + (case (resolve-struct-type type) + (#Some (#RecordT slots)) + (do Lux/Monad + [pattern' (map% Lux/Monad + (: (-> (, Text Type) (Lux (, Text Syntax))) + (lambda [slot] + (let [[r-slot-name r-type] slot] + (do Lux/Monad + [g!slot (gensym "")] + (return [r-slot-name g!slot]))))) + slots) + slot (normalize slot')] + (let [[s-prefix s-name] (: Ident slot) + pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-var] slot] + [(tag$ (split-slot r-slot-name)) r-var]))) + pattern')) + output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[r-slot-name r-var] slot + [r-prefix r-name] (split-slot r-slot-name)] + [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) + (text:= s-name r-name)) + (` ((~ fun) (~ r-var))) + r-var)]))) + pattern'))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + + _ + (fail "update@ can only use records."))) + + _ + (do Lux/Monad + [_record (gensym "")] + (return (list (` (let [(~ _record) (~ record)] + (update@ (~ (tag$ slot')) (~ fun) (~ _record)))))))) + + _ + (fail "Wrong syntax for update@"))) + +(defmacro #export (\template tokens) + (case tokens + (\ (list (#Meta [_ (#TupleS data)]) + (#Meta [_ (#TupleS bindings)]) + (#Meta [_ (#TupleS templates)]))) + (case (: (Maybe (List Syntax)) + (do Maybe/Monad + [bindings' (map% Maybe/Monad get-ident bindings) + data' (map% Maybe/Monad tuple->list data)] + (let [apply (: (-> RepEnv (List Syntax)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + ;return)))) + (#Some output) + (return output) + + #None + (fail "Wrong syntax for \\template")) + + _ + (fail "Wrong syntax for \\template"))) + +(def #export complement + (All [a] (-> (-> a Bool) (-> a Bool))) + (. not)) + +## (defmacro #export (loop tokens) +## (case tokens +## (\ (list bindings body)) +## (let [pairs (as-pairs bindings) +## vars (map first pairs) +## inits (map second pairs)] +## (if (every? symbol? inits) +## (do Lux/Monad +## [inits' (map% Maybe/Monad get-ident inits) +## init-types (map% Maybe/Monad find-var-type inits')] +## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] +## (~ body)) +## (~@ inits)))))) +## (do Lux/Monad +## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)] +## (return (list (` (let [(~@ (interleave aliases inits))] +## (loop [(~@ (interleave vars aliases))] +## (~ body))))))))) + +## _ +## (fail "Wrong syntax for loop"))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux new file mode 100644 index 000000000..1d6dd1b50 --- /dev/null +++ b/source/lux/codata/stream.lux @@ -0,0 +1,133 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (control (lazy #as L #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all) + (comonad #as CM #refer #all)) + (meta lux + macro + syntax) + (data (list #as l #refer (#only list list& List/Monad))))) + +## [Types] +(deftype #export (Stream a) + (Lazy (, a (Stream a)))) + +## [Utils] +(def (cycle' x xs init full) + (All [a] + (-> a (List a) a (List a) (Stream a))) + (case xs + #;Nil (cycle' init full init full) + (#;Cons [y xs']) (... [x (cycle' y xs' init full)]))) + +## [Functions] +(def #export (iterate f x) + (All [a] + (-> (-> a a) a (Stream a))) + (... [x (iterate f (f x))])) + +(def #export (repeat x) + (All [a] + (-> a (Stream a))) + (... [x (repeat x)])) + +(def #export (cycle xs) + (All [a] + (-> (List a) (Maybe (Stream a)))) + (case xs + #;Nil #;None + (#;Cons [x xs']) (#;Some (cycle' x xs' x xs')))) + +(do-template [ ] + [(def #export ( s) + (All [a] (-> (Stream a) )) + (let [[h t] (! s)] + ))] + + [head a h] + [tail (Stream a) t]) + +(def #export (@ idx s) + (All [a] (-> Int (Stream a) a)) + (let [[h t] (! s)] + (if (i> idx 0) + (@ (dec idx) t) + h))) + +(do-template [ ] + [(def #export ( det xs) + (All [a] + (-> (Stream a) (List a))) + (let [[x xs'] (! xs)] + (if + (list& x ( xs')) + (list)))) + + (def #export ( det xs) + (All [a] + (-> (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if + ( xs') + xs))) + + (def #export ( det xs) + (All [a] + (-> (Stream a) (, (List a) (Stream a)))) + (let [[x xs'] (! xs)] + (if + (let [[tail next] ( xs')] + [(#;Cons [x tail]) next]) + [(list) xs])))] + + [take-while drop-while split-with (-> a Bool) (det x) det] + [take drop split Int (i> det 0) (dec det)] + ) + +(def #export (unfold step init) + (All [a b] + (-> (-> a (, a b)) a (Stream b))) + (let [[next x] (step init)] + (... [x (unfold step next)]))) + +(def #export (filter p xs) + (All [a] (-> (-> a Bool) (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if (p x) + (... [x (filter p xs')]) + (filter p xs')))) + +(def #export (partition p xs) + (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a)))) + [(filter p xs) (filter (complement p) xs)]) + +## [Structures] +(defstruct #export Stream/Functor (Functor Stream) + (def (F;map f fa) + (let [[h t] (! fa)] + (... [(f h) (F;map f t)])))) + +(defstruct #export Stream/CoMonad (CoMonad Stream) + (def CM;_functor Stream/Functor) + (def CM;unwrap head) + (def (CM;split wa) + (:: Stream/Functor (F;map repeat wa)))) + +## [Pattern-matching] +(defsyntax #export (\stream body [patterns' (+^ id^)]) + (do Lux/Monad + [patterns (map% Lux/Monad macro-expand-1 patterns') + g!s (gensym "s") + #let [patterns+ (: (List Syntax) + (do List/Monad + [pattern (l;reverse patterns)] + (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] + (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux new file mode 100644 index 000000000..1830ff44f --- /dev/null +++ b/source/lux/control/comonad.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (../functor #as F) + lux/data/list + lux/meta/macro) + +## Signatures +(defsig #export (CoMonad w) + (: (F;Functor w) + _functor) + (: (All [a] + (-> (w a) a)) + unwrap) + (: (All [a] + (-> (w a) (w (w a)))) + split)) + +## Functions +(def #export (extend w f ma) + (All [w a b] + (-> (CoMonad w) (-> (w a) b) (w a) (w b))) + (using w + (using ;;_functor + (F;map f (;;split ma))))) + +## Syntax +(defmacro #export (be tokens state) + (case tokens + (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (case var + (#;Meta [_ (#;TagS ["" "let"])]) + (` (;let (~ value) (~ body'))) + + _ + (` (extend (;lambda [(~ var)] (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (list (` (;case (~ monad) + {#;return ;return #;bind ;bind} + (~ body'))))])) + + _ + (#;Left "Wrong syntax for be"))) diff --git a/source/lux/control/functor.lux b/source/lux/control/functor.lux new file mode 100644 index 000000000..6a9dcfff8 --- /dev/null +++ b/source/lux/control/functor.lux @@ -0,0 +1,15 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Functor f) + (: (All [a b] + (-> (-> a b) (f a) (f b))) + map)) diff --git a/source/lux/control/lazy.lux b/source/lux/control/lazy.lux new file mode 100644 index 000000000..22dac74fe --- /dev/null +++ b/source/lux/control/lazy.lux @@ -0,0 +1,47 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/meta macro) + (.. (functor #as F #refer #all) + (monad #as M #refer #all)) + (lux/data list)) + +## Types +(deftype #export (Lazy a) + (All [b] + (-> (-> a b) b))) + +## Syntax +(defmacro #export (... tokens state) + (case tokens + (\ (list value)) + (let [blank (symbol$ ["" ""])] + (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) + + _ + (#;Left "Wrong syntax for ..."))) + +## Functions +(def #export (! thunk) + (All [a] + (-> (Lazy a) a)) + (thunk id)) + +## Structs +(defstruct #export Lazy/Functor (Functor Lazy) + (def (F;map f ma) + (lambda [k] (ma (. k f))))) + +(defstruct #export Lazy/Monad (Monad Lazy) + (def M;_functor Lazy/Functor) + + (def (M;wrap a) + (... a)) + + (def M;join !)) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux new file mode 100644 index 000000000..b5552f987 --- /dev/null +++ b/source/lux/control/monad.lux @@ -0,0 +1,99 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. (functor #as F) + (monoid #as M)) + lux/meta/macro) + +## [Utils] +(def (foldL f init xs) + (All [a b] + (-> (-> a b a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + +(def (reverse xs) + (All [a] + (-> (List a) (List a))) + (foldL (lambda [tail head] (#;Cons [head tail])) + #;Nil + xs)) + +(def (as-pairs xs) + (All [a] (-> (List a) (List (, a a)))) + (case xs + (#;Cons [x1 (#;Cons [x2 xs'])]) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +## [Signatures] +(defsig #export (Monad m) + (: (F;Functor m) + _functor) + (: (All [a] + (-> a (m a))) + wrap) + (: (All [a] + (-> (m (m a)) (m a))) + join)) + +## [Syntax] +(defmacro #export (do tokens state) + (case tokens + ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) + (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (case var + (#;Meta [_ (#;TagS ["" "let"])]) + (` (;let (~ value) (~ body'))) + + _ + (` (;case ;;_functor + {#F;map F;map} + (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join)))) + ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) + )))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (#;Cons [(` (;case (~ monad) + {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} + (~ body'))) + #;Nil])])) + + _ + (#;Left "Wrong syntax for do"))) + +## [Functions] +(def #export (bind m f ma) + (All [m a b] + (-> (Monad m) (-> a (m b)) (m a) (m b))) + (using m + (;;join (:: ;;_functor (F;map f ma))))) + +(def #export (map% m f xs) + (All [m a b] + (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (case xs + #;Nil + (:: m (;;wrap #;Nil)) + + (#;Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;;wrap (#;Cons [y ys]))) + )) diff --git a/source/lux/control/monoid.lux b/source/lux/control/monoid.lux new file mode 100644 index 000000000..d32baabc5 --- /dev/null +++ b/source/lux/control/monoid.lux @@ -0,0 +1,24 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Monoid a) + (: a + unit) + (: (-> a a a) + ++)) + +## Constructors +(def #export (monoid$ unit ++) + (All [a] + (-> a (-> a a a) (Monoid a))) + (struct + (def unit unit) + (def ++ ++))) diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux new file mode 100644 index 000000000..d4f223612 --- /dev/null +++ b/source/lux/data/bool.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m)) + (.. (eq #as E) + (show #as S))) + +## [Structures] +(defstruct #export Bool/Eq (E;Eq Bool) + (def (E;= x y) + (if x + y + (not y)))) + +(defstruct #export Bool/Show (S;Show Bool) + (def (S;show x) + (if x "true" "false"))) + +(do-template [ ] + [(defstruct #export (m;Monoid Bool) + (def m;unit ) + (def (m;++ x y) + ( x y)))] + + [ Or/Monoid false or] + [And/Monoid true and] + ) diff --git a/source/lux/data/bounded.lux b/source/lux/data/bounded.lux new file mode 100644 index 000000000..9d2dabde1 --- /dev/null +++ b/source/lux/data/bounded.lux @@ -0,0 +1,17 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Bounded a) + (: a + top) + + (: a + bottom)) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux new file mode 100644 index 000000000..42e57509e --- /dev/null +++ b/source/lux/data/char.lux @@ -0,0 +1,20 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. (eq #as E) + (show #as S))) + +## [Structures] +(defstruct #export Char/Eq (E;Eq Char) + (def (E;= x y) + (_jvm_ceq x y))) + +(defstruct #export Char/Show (S;Show Char) + (def (S;show x) + ($ text:++ "#\"" (_jvm_invokevirtual java.lang.Object toString [] x []) "\""))) diff --git a/source/lux/data/dict.lux b/source/lux/data/dict.lux new file mode 100644 index 000000000..63a66d49b --- /dev/null +++ b/source/lux/data/dict.lux @@ -0,0 +1,83 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data (eq #as E))) + +## Signatures +(defsig #export (Dict d) + (: (All [k v] + (-> k (d k v) (Maybe v))) + get) + (: (All [k v] + (-> k v (d k v) (d k v))) + put) + (: (All [k v] + (-> k (d k v) (d k v))) + remove)) + +## Types +(deftype #export (PList k v) + (| (#PList (, (E;Eq k) (List (, k v)))))) + +## Constructors +(def #export (plist eq) + (All [k v] + (-> (E;Eq k) (PList k v))) + (#PList [eq #;Nil])) + +## Utils +(def (pl-get eq k kvs) + (All [k v] + (-> (E;Eq k) k (List (, k v)) (Maybe v))) + (case kvs + #;Nil + #;None + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + (#;Some v') + (pl-get eq k kvs')))) + +(def (pl-put eq k v kvs) + (All [k v] + (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) + (case kvs + #;Nil + (#;Cons [[k v] kvs]) + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + (#;Cons [[k v] kvs']) + (#;Cons [[k' v'] (pl-put eq k v kvs')])))) + +(def (pl-remove eq k kvs) + (All [k v] + (-> (E;Eq k) k (List (, k v)) (List (, k v)))) + (case kvs + #;Nil + kvs + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + kvs' + (#;Cons [[k' v'] (pl-remove eq k kvs')])))) + +## Structs +(defstruct #export PList/Dict (Dict PList) + (def (get k plist) + (let [(#PList [eq kvs]) plist] + (pl-get eq k kvs))) + + (def (put k v plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-put eq k v kvs)]))) + + (def (remove k plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-remove eq k kvs)])))) diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux new file mode 100644 index 000000000..eba6438db --- /dev/null +++ b/source/lux/data/either.lux @@ -0,0 +1,46 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data (list #refer (#exclude partition)))) + +## [Types] +## (deftype (Either l r) +## (| (#;Left l) +## (#;Right r))) + +## [Functions] +(def #export (either f g e) + (All [a b c] (-> (-> a c) (-> b c) (Either a b) c)) + (case e + (#;Left x) (f x) + (#;Right x) (g x))) + +(do-template [ ] + [(def #export ( es) + (All [a b] (-> (List (Either a b)) (List ))) + (case es + #;Nil #;Nil + (#;Cons [( x) es']) (#;Cons [x ( es')]) + (#;Cons [_ es']) ( es')))] + + [lefts a #;Left] + [rights b #;Right] + ) + +(def #export (partition es) + (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) + (foldL (: (All [a b] + (-> (, (List a) (List b)) (Either a b) (, (List a) (List b)))) + (lambda [tails e] + (let [[ltail rtail] tails] + (case e + (#;Left x) [(#;Cons [x ltail]) rtail] + (#;Right x) [ltail (#;Cons [x rtail])])))) + [(list) (list)] + (reverse es))) diff --git a/source/lux/data/eq.lux b/source/lux/data/eq.lux new file mode 100644 index 000000000..be3400208 --- /dev/null +++ b/source/lux/data/eq.lux @@ -0,0 +1,14 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Signatures] +(defsig #export (Eq a) + (: (-> a a Bool) + =)) diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux new file mode 100644 index 000000000..cb5c309a6 --- /dev/null +++ b/source/lux/data/error.lux @@ -0,0 +1,34 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Error a) + (| (#Fail Text) + (#Ok a))) + +## [Structures] +(defstruct #export Error/Functor (Functor Error) + (def (F;map f ma) + (case ma + (#Fail msg) (#Fail msg) + (#Ok datum) (#Ok (f datum))))) + +(defstruct #export Error/Monad (Monad Error) + (def M;_functor Error/Functor) + + (def (M;wrap a) + (#Ok a)) + + (def (M;join mma) + (case mma + (#Fail msg) (#Fail msg) + (#Ok ma) ma))) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux new file mode 100644 index 000000000..0e3bdbee6 --- /dev/null +++ b/source/lux/data/id.lux @@ -0,0 +1,28 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Id a) + (| (#Id a))) + +## [Structures] +(defstruct #export Id/Functor (Functor Id) + (def (F;map f fa) + (let [(#Id a) fa] + (#Id (f a))))) + +(defstruct #export Id/Monad (Monad Id) + (def M;_functor Id/Functor) + (def (M;wrap a) (#Id a)) + (def (M;join mma) + (let [(#Id ma) mma] + ma))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux new file mode 100644 index 000000000..c08023df5 --- /dev/null +++ b/source/lux/data/io.lux @@ -0,0 +1,51 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/meta macro) + (lux/control (functor #as F) + (monad #as M)) + lux/data/list) + +## Types +(deftype #export (IO a) + (-> (,) a)) + +## Syntax +(defmacro #export (io tokens state) + (case tokens + (\ (list value)) + (let [blank (symbol$ ["" ""])] + (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))])) + + _ + (#;Left "Wrong syntax for io"))) + +## Structures +(defstruct #export IO/Functor (F;Functor IO) + (def (F;map f ma) + (io (f (ma []))))) + +(defstruct #export IO/Monad (M;Monad IO) + (def M;_functor IO/Functor) + + (def (M;wrap x) + (io x)) + + (def (M;join mma) + (mma []))) + +## Functions +(def #export (print x) + (-> Text (IO (,))) + (io (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [x]))) + +(def #export (println x) + (-> Text (IO (,))) + (print (text:++ x "\n"))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux new file mode 100644 index 000000000..450dee275 --- /dev/null +++ b/source/lux/data/list.lux @@ -0,0 +1,250 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all)) + lux/meta/macro) + +## Types +## (deftype (List a) +## (| #Nil +## (#Cons (, a (List a))))) + +## Functions +(def #export (foldL f init xs) + (All [a b] + (-> (-> a b a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + +(def #export (foldR f init xs) + (All [a b] + (-> (-> b a a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (f x (foldR f init xs')))) + +(def #export (reverse xs) + (All [a] + (-> (List a) (List a))) + (foldL (lambda [tail head] (#;Cons [head tail])) + #;Nil + xs)) + +(def #export (filter p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + (#;Cons [x (filter p xs')]) + (filter p xs')))) + +(def #export (partition p xs) + (All [a] (-> (-> a Bool) (List a) (, (List a) (List a)))) + [(filter p xs) (filter (complement p) xs)]) + +(def #export (as-pairs xs) + (All [a] (-> (List a) (List (, a a)))) + (case xs + (\ (#;Cons [x1 (#;Cons [x2 xs'])])) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +(do-template [ ] + [(def #export ( n xs) + (All [a] + (-> Int (List a) (List a))) + (if (i> n 0) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + ) + ))] + + [take (#;Cons [x (take (dec n) xs')]) #;Nil] + [drop (drop (dec n) xs') xs] + ) + +(do-template [ ] + [(def #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + + )))] + + [take-while (#;Cons [x (take-while p xs')]) #;Nil] + [drop-while (drop-while p xs') xs] + ) + +(def #export (split n xs) + (All [a] + (-> Int (List a) (, (List a) (List a)))) + (if (i> n 0) + (case xs + #;Nil + [#;Nil #;Nil] + + (#;Cons [x xs']) + (let [[tail rest] (split (dec n) xs')] + [(#;Cons [x tail]) rest])) + [#;Nil xs])) + +(def (split-with' p ys xs) + (All [a] + (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) + (case xs + #;Nil + [ys xs] + + (#;Cons [x xs']) + (if (p x) + (split-with' p (#;Cons [x ys]) xs') + [ys xs]))) + +(def #export (split-with p xs) + (All [a] + (-> (-> a Bool) (List a) (, (List a) (List a)))) + (let [[ys' xs'] (split-with' p #;Nil xs)] + [(reverse ys') xs'])) + +(def #export (repeat n x) + (All [a] + (-> Int a (List a))) + (if (i> n 0) + (#;Cons [x (repeat (dec n) x)]) + #;Nil)) + +(def #export (iterate f x) + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#;Some x') + (#;Cons [x (iterate f x')]) + + #;None + (#;Cons [x #;Nil]))) + +(def #export (some f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #;Nil + #;None + + (#;Cons [x xs']) + (case (f x) + #;None + (some f xs') + + (#;Some y) + (#;Some y)))) + +(def #export (interpose sep xs) + (All [a] + (-> a (List a) (List a))) + (case xs + #;Nil + xs + + (#;Cons [x #;Nil]) + xs + + (#;Cons [x xs']) + (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) + +(def #export (size list) + (-> List Int) + (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) + +(do-template [ ] + [(def #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (foldL (lambda [_1 _2] ( _1 (p _2))) xs))] + + [every? true and] + [any? false or]) + +(def #export (@ i xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons [x xs']) + (if (i= 0 i) + (#;Some x) + (@ (dec i) xs')))) + +## Syntax +(defmacro #export (list xs state) + (#;Right [state (#;Cons [(foldL (lambda [tail head] + (` (#;Cons [(~ head) (~ tail)]))) + (` #;Nil) + (reverse xs)) + #;Nil])])) + +(defmacro #export (list& xs state) + (case (reverse xs) + (#;Cons [last init]) + (#;Right [state (list (foldL (lambda [tail head] + (` (#;Cons [(~ head) (~ tail)]))) + last + init))]) + + _ + (#;Left "Wrong syntax for list&"))) + +## Structures +(defstruct #export List/Monoid (All [a] + (Monoid (List a))) + (def m;unit #;Nil) + (def (m;++ xs ys) + (case xs + #;Nil ys + (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)])))) + +(defstruct #export List/Functor (Functor List) + (def (F;map f ma) + (case ma + #;Nil #;Nil + (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')])))) + +(defstruct #export List/Monad (Monad List) + (def M;_functor List/Functor) + + (def (M;wrap a) + (#;Cons [a #;Nil])) + + (def (M;join mma) + (using List/Monoid + (foldL m;++ m;unit mma)))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux new file mode 100644 index 000000000..faec53c2e --- /dev/null +++ b/source/lux/data/maybe.lux @@ -0,0 +1,42 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +## (deftype (Maybe a) +## (| #;None +## (#;Some a))) + +## [Structures] +(defstruct #export Maybe/Monoid (Monoid Maybe) + (def m;unit #;None) + (def (m;++ xs ys) + (case xs + #;None ys + (#;Some x) (#;Some x)))) + +(defstruct #export Maybe/Functor (Functor Maybe) + (def (F;map f ma) + (case ma + #;None #;None + (#;Some a) (#;Some (f a))))) + +(defstruct #export Maybe/Monad (Monad Maybe) + (def M;_functor Maybe/Functor) + + (def (M;wrap x) + (#;Some x)) + + (def (M;join mma) + (case mma + #;None #;None + (#;Some xs) xs))) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux new file mode 100644 index 000000000..8da674d88 --- /dev/null +++ b/source/lux/data/number.lux @@ -0,0 +1,119 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m)) + (lux/data (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) + +## Signatures +(defsig #export (Number n) + (do-template [] + [(: (-> n n n) )] + [+] [-] [*] [/] [%]) + + (: (-> Int n) + from-int) + + (do-template [] + [(: (-> n n) )] + [negate] [signum] [abs]) + ) + +## [Structures] +## Number +(do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] + [(defstruct #export (Number ) + (def + <+>) + (def - <->) + (def * <*>) + (def / ) + (def % <%>) + (def (from-int x) + ( x)) + (def (negate x) + (<*> <-1> x)) + (def (abs x) + (if (<<> x <0>) + (<*> <-1> x) + x)) + (def (signum x) + (cond (<=> x <0>) <0> + (<<> x <0>) <-1> + ## else + <1>)) + )] + + [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1] + [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0]) + +## Eq +(defstruct #export Int/Eq (E;Eq Int) + (def E;= i=)) + +(defstruct #export Real/Eq (E;Eq Real) + (def E;= r=)) + +## Ord +## (def #export Int/Ord (O;Ord Int) +## (O;ord$ Int/Eq i< i>)) + +## (def #export Real/Ord (O;Ord Real) +## (O;ord$ Real/Eq r< r>)) + +(do-template [ ] + [(defstruct #export (O;Ord ) + (def O;_eq ) + (def O;< ) + (def (O;<= x y) + (or ( x y) + (using (E;= x y)))) + (def O;> ) + (def (O;>= x y) + (or ( x y) + (using (E;= x y)))))] + + [ Int/Ord Int Int/Eq i< i>] + [Real/Ord Real Real/Eq r< r>]) + +## Bounded +(do-template [ ] + [(defstruct #export (B;Bounded ) + (def B;top ) + (def B;bottom ))] + + [ Int/Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] + [Real/Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) + +## Monoid +(do-template [ <++>] + [(defstruct #export (m;Monoid ) + (def m;unit ) + (def m;++ <++>))] + + [ IntAdd/Monoid Int 0 i+] + [ IntMul/Monoid Int 1 i*] + [RealAdd/Monoid Real 0.0 r+] + [RealMul/Monoid Real 1.0 r*] + [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] + [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] + [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] + [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] + ) + +## Show +(do-template [ ] + [(defstruct #export (S;Show ) + (def (S;show x) + ))] + + [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] + ) diff --git a/source/lux/data/ord.lux b/source/lux/data/ord.lux new file mode 100644 index 000000000..80f2e4fb5 --- /dev/null +++ b/source/lux/data/ord.lux @@ -0,0 +1,44 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (../eq #as E)) + +## [Signatures] +(defsig #export (Ord a) + (: (E;Eq a) + _eq) + (do-template [] + [(: (-> a a Bool) )] + + [<] [<=] [>] [>=])) + +## [Constructors] +(def #export (ord$ eq < >) + (All [a] + (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) + (struct + (def _eq eq) + (def < <) + (def (<= x y) + (or (< x y) + (:: eq (E;= x y)))) + (def > >) + (def (>= x y) + (or (> x y) + (:: eq (E;= x y)))))) + +## [Functions] +(do-template [ ] + [(def #export ( ord x y) + (All [a] + (-> (Ord a) a a a)) + (if (:: ord ( x y)) x y))] + + [max ;;>] + [min ;;<]) diff --git a/source/lux/data/reader.lux b/source/lux/data/reader.lux new file mode 100644 index 000000000..e91687c3a --- /dev/null +++ b/source/lux/data/reader.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import (lux #refer (#exclude Reader)) + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Reader r a) + (-> r a)) + +## [Structures] +(defstruct #export Reader/Functor (All [r] + (Functor (Reader r))) + (def (F;map f fa) + (lambda [env] + (f (fa env))))) + +(defstruct #export Reader/Monad (All [r] + (Monad (Reader r))) + (def M;_functor Reader/Functor) + + (def (M;wrap x) + (lambda [env] x)) + + (def (M;join mma) + (lambda [env] + (mma env env)))) diff --git a/source/lux/data/show.lux b/source/lux/data/show.lux new file mode 100644 index 000000000..f4e1cf762 --- /dev/null +++ b/source/lux/data/show.lux @@ -0,0 +1,14 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Show a) + (: (-> a Text) + show)) diff --git a/source/lux/data/state.lux b/source/lux/data/state.lux new file mode 100644 index 000000000..bc9858a29 --- /dev/null +++ b/source/lux/data/state.lux @@ -0,0 +1,35 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (State s a) + (-> s (, s a))) + +## [Structures] +(defstruct #export State/Functor (Functor State) + (def (F;map f ma) + (lambda [state] + (let [[state' a] (ma state)] + [state' (f a)])))) + +(defstruct #export State/Monad (All [s] + (Monad (State s))) + (def M;_functor State/Functor) + + (def (M;wrap x) + (lambda [state] + [state x])) + + (def (M;join mma) + (lambda [state] + (let [[state' ma] (mma state)] + (ma state'))))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux new file mode 100644 index 000000000..a3192a1d5 --- /dev/null +++ b/source/lux/data/text.lux @@ -0,0 +1,146 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m)) + (lux/data (eq #as E) + (ord #as O) + (show #as S))) + +## [Functions] +(def #export (size x) + (-> Text Int) + (_jvm_i2l (_jvm_invokevirtual java.lang.String length [] + x []))) + +(def #export (@ idx x) + (-> Int Text (Maybe Char)) + (if (and (i< idx (size x)) + (i>= idx 0)) + (#;Some (_jvm_invokevirtual java.lang.String charAt [int] + x [(_jvm_l2i idx)])) + #;None)) + +(def #export (contains? x y) + (-> Text Text Bool) + (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence] + x [y])) + +(do-template [ ] + [(def #export ( x) + (-> Text Text) + (_jvm_invokevirtual java.lang.String [] + x []))] + [lower-case toLowerCase] + [upper-case toUpperCase] + [trim trim] + ) + +(def #export (sub' from to x) + (-> Int Int Text (Maybe Text)) + (if (and (i< from to) + (i>= from 0) + (i<= to (size x))) + (_jvm_invokevirtual java.lang.String substring [int int] + x [(_jvm_l2i from) (_jvm_l2i to)]) + #;None)) + +(def #export (sub from x) + (-> Int Text (Maybe Text)) + (sub' from (size x) x)) + +(def #export (split at x) + (-> Int Text (Maybe (, Text Text))) + (if (and (i< at (size x)) + (i>= at 0)) + (let [pre (_jvm_invokevirtual java.lang.String substring [int int] + x [(_jvm_l2i 0) (_jvm_l2i at)]) + post (_jvm_invokevirtual java.lang.String substring [int] + x [(_jvm_l2i at)])] + (#;Some [pre post])) + #;None)) + +(def #export (replace pattern value template) + (-> Text Text Text Text) + (_jvm_invokevirtual java.lang.String replace [java.lang.CharSequence java.lang.CharSequence] + template [pattern value])) + +(do-template [ ] + [(def #export ( pattern from x) + (-> Text Int Text (Maybe Int)) + (if (and (i< from (size x)) (i>= from 0)) + (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String int] + x [pattern (_jvm_l2i from)])) + -1 #;None + idx (#;Some idx)) + #;None)) + + (def #export ( pattern x) + (-> Text Text (Maybe Int)) + (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String] + x [pattern])) + -1 #;None + idx (#;Some idx)))] + + [index-of index-of' indexOf] + [last-index-of last-index-of' lastIndexOf] + ) + +(def #export (starts-with? prefix x) + (-> Text Text Bool) + (case (index-of prefix x) + (#;Some 0) + true + + _ + false)) + +(def #export (ends-with? postfix x) + (-> Text Text Bool) + (case (last-index-of postfix x) + (#;Some n) + (i= (i+ n (size postfix)) + (size x)) + + _ + false)) + +## [Structures] +(defstruct #export Text/Eq (E;Eq Text) + (def (E;= x y) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y]))) + +(defstruct #export Text/Ord (O;Ord Text) + (def O;_eq Text/Eq) + (def (O;< x y) + (i< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;<= x y) + (i<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;> x y) + (i> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;>= x y) + (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0))) + +(defstruct #export Text/Show (S;Show Text) + (def (S;show x) + x)) + +(defstruct #export Text/Monoid (m;Monoid Text) + (def m;unit "") + (def (m;++ x y) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y]))) diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux new file mode 100644 index 000000000..f71492e35 --- /dev/null +++ b/source/lux/data/writer.lux @@ -0,0 +1,34 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Writer l a) + (, l a)) + +## [Structures] +(defstruct #export Writer/Functor (All [l] + (Functor (Writer l))) + (def (F;map f fa) + (let [[log datum] fa] + [log (f datum)]))) + +(defstruct #export (Writer/Monad mon) (All [l] + (-> (Monoid l) (Monad (Writer l)))) + (def M;_functor Writer/Functor) + + (def (M;wrap x) + [(:: mon m;unit) x]) + + (def (M;join mma) + (let [[log1 [log2 a]] mma] + [(:: mon (m;++ log1 log2)) a]))) diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux new file mode 100644 index 000000000..12525d3f2 --- /dev/null +++ b/source/lux/host/java.lux @@ -0,0 +1,312 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (control (monoid #as m) + (functor #as F) + (monad #as M #refer (#only do))) + (data list + (text #as text)) + (meta lux + macro + syntax))) + +## (open List/Functor) + +## [Utils/Parsers] +(def finally^ + (Parser Syntax) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "finally"]) + expr id^ + _ end^] + (M;wrap expr)))) + +(def catch^ + (Parser (, Text Ident Syntax)) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "catch"]) + ex-class local-symbol^ + ex symbol^ + expr id^ + _ end^] + (M;wrap [ex-class ex expr])))) + +(def method-decl^ + (Parser (, (List Text) Text (List Text) Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ local-symbol^)) + output local-symbol^ + _ end^] + (M;wrap [modifiers name inputs output])))) + +(def field-decl^ + (Parser (, (List Text) Text Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + class local-symbol^ + _ end^] + (M;wrap [modifiers name class])))) + +(def arg-decl^ + (Parser (, Text Text)) + (form^ (do Parser/Monad + [arg-name local-symbol^ + arg-class local-symbol^ + _ end^] + (M;wrap [arg-name arg-class])))) + +(def method-def^ + (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ arg-decl^)) + output local-symbol^ + body id^ + _ end^] + (M;wrap [modifiers name inputs output body])))) + +(def method-call^ + (Parser (, Text (List Text) (List Syntax))) + (form^ (do Parser/Monad + [method local-symbol^ + arity-classes (tuple^ (*^ local-symbol^)) + arity-args (tuple^ (*^ id^)) + _ end^ + _ (: (Parser (,)) + (if (i= (size arity-classes) + (size arity-args)) + (M;wrap []) + (lambda [_] #;None)))] + (M;wrap [method arity-classes arity-args]) + ))) + +## [Utils/Lux] +## (def (find-class-field field class) +## (-> Text Text (Lux Type)) +## ...) + +## (def (find-virtual-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + +## (def (find-static-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + + +## [Syntax] +(defsyntax #export (throw ex) + (emit (list (` (_jvm_throw (~ ex)))))) + +(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) + (emit (list (` (_jvm_try (~ body) + (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax) + (lambda [catch] + (let [[class ex body] catch] + (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches)) + (case finally + #;None + (list) + + (#;Some finally) + (list (` (_jvm_finally (~ finally)))))))))))) + +(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name))]] + (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + members))] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))] + (~@ members')))))))) + +(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [fields (*^ field-decl^)] + [methods (*^ method-def^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name)) + fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" name])) + (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + fields)) + methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (symbol$ ["" name])) + [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs)))] + (~ (text$ output)) + [(~@ (:: List/Functor (F;map text$ modifiers)))] + (~ body)))))) + methods))]] + (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) + [(~@ (:: List/Functor (F;map text$ interfaces)))] + [(~@ fields')] + [(~@ methods')])))))) + +(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) + (emit (list (` (_jvm_new (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ arg-classes)))] + [(~@ args)]))))) + +(defsyntax #export (instance? [class local-symbol^] obj) + (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) + +(defsyntax #export (locking lock body) + (do Lux/Monad + [g!lock (gensym "") + g!body (gensym "")] + (emit (list (` (;let [(~ g!lock) (~ lock) + _ (_jvm_monitor-enter (~ g!lock)) + (~ g!body) (~ body) + _ (_jvm_monitor-exit (~ g!lock))] + (~ g!body))))) + )) + +(defsyntax #export (null? obj) + (emit (list (` (_jvm_null? (~ obj)))))) + +(defsyntax #export (program [args symbol^] body) + (emit (list (` (_jvm_program (~ (symbol$ args)) + (~ body)))))) + +## (defsyntax #export (.? [field local-symbol^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)))) + +## _ +## (fail "Can only get field from object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.? (~ field) (~ g!obj))))))))) + +## (defsyntax #export (.= [field local-symbol^] value obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value))) + +## _ +## (fail "Can only set field of object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.= (~ field) (~ value) (~ g!obj))))))))) + +## (defsyntax #export (.! [call method-call^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-virtual-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))] +## (~ obj) [(~@ m-args)]))))) + +## _ +## (fail "Can only call method on object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.! (~@ *tokens*))))))))) + +## (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) +## (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) + +## (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) +## (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) + +## (defsyntax #export (..! [call method-call^] [class local-symbol^]) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-static-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class)) +## [(~@ (:: List/Functor (F;map text$ m-ins)))] +## [(~@ m-args)])))) +## )) + +## (definterface Function [] +## (#public #abstract apply [java.lang.Object] java.lang.Object)) + +## (_jvm_interface "Function" [] +## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (defclass MyFunction [Function] +## (#public #static foo java.lang.Object) +## (#public [] void +## (_jvm_invokespecial java.lang.Object [] this [])) +## (#public apply [(arg java.lang.Object)] java.lang.Object +## "YOLO")) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## ( [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) diff --git a/source/lux/math.lux b/source/lux/math.lux new file mode 100644 index 000000000..2e29c5da7 --- /dev/null +++ b/source/lux/math.lux @@ -0,0 +1,60 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Constants] +(do-template [ ] + [(def #export + Real + (_jvm_getstatic java.lang.Math ))] + + [e E] + [pi PI] + ) + +## [Functions] +(do-template [ ] + [(def #export ( n) + (-> Real Real) + (_jvm_invokestatic java.lang.Math [double] [n]))] + + [cos cos] + [sin sin] + [tan tan] + + [acos acos] + [asin asin] + [atan atan] + + [cosh cosh] + [sinh sinh] + [tanh tanh] + + [ceil ceil] + [floor floor] + [round round] + + [exp exp] + [log log] + + [cbrt cbrt] + [sqrt sqrt] + + [->degrees toDegrees] + [->radians toRadians] + ) + +(do-template [ ] + [(def #export ( x y) + (-> Real Real Real) + (_jvm_invokestatic java.lang.Math [double double] [x y]))] + + [atan2 atan2] + [pow pow] + ) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux new file mode 100644 index 000000000..a28d6e5d4 --- /dev/null +++ b/source/lux/meta/lux.lux @@ -0,0 +1,287 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. macro) + (lux/control (monoid #as m) + (functor #as F) + (monad #as M #refer (#only do))) + (lux/data list + maybe + (show #as S) + (number #as N))) + +## [Types] +## (deftype (Lux a) +## (-> Compiler (Either Text (, Compiler a)))) + +## [Utils] +(def (ident->text ident) + (-> Ident Text) + (let [[pre post] ident] + ($ text:++ pre ";" post))) + +## [Structures] +(defstruct #export Lux/Functor (F;Functor Lux) + (def (F;map f fa) + (lambda [state] + (case (fa state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' a]) + (#;Right [state' (f a)]))))) + +(defstruct #export Lux/Monad (M;Monad Lux) + (def M;_functor Lux/Functor) + (def (M;wrap x) + (lambda [state] + (#;Right [state x]))) + (def (M;join mma) + (lambda [state] + (case (mma state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' ma]) + (ma state'))))) + +## Functions +(def #export (get-module-name state) + (Lux Text) + (case (reverse (get@ #;envs state)) + #;Nil + (#;Left "Can't get the module name without a module!") + + (#;Cons [env _]) + (#;Right [state (get@ #;name env)]))) + +(def (get k plist) + (All [a] + (-> Text (List (, Text a)) (Maybe a))) + (case plist + #;Nil + #;None + + (#;Cons [[k' v] plist']) + (if (text:= k k') + (#;Some v) + (get k plist')))) + +(def (find-macro' modules current-module module name) + (-> (List (, Text (Module Compiler))) Text Text Text + (Maybe Macro)) + (do Maybe/Monad + [$module (get module modules) + gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))] + (case (: (, Bool (DefData' Macro)) gdef) + [exported? (#;MacroD macro')] + (if (or exported? (text:= module current-module)) + (#;Some macro') + #;None) + + [_ (#;AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #;None))) + +(def #export (find-macro ident) + (-> Ident (Lux (Maybe Macro))) + (do Lux/Monad + [current-module get-module-name] + (let [[module name] ident] + (: (Lux (Maybe Macro)) + (lambda [state] + (#;Right [state (find-macro' (get@ #;modules state) current-module module name)])))))) + +(def #export (normalize ident) + (-> Ident (Lux Ident)) + (case ident + ["" name] + (do Lux/Monad + [module-name get-module-name] + (M;wrap (: Ident [module-name name]))) + + _ + (:: Lux/Monad (M;wrap ident)))) + +(def #export (macro-expand syntax) + (-> Syntax (Lux (List Syntax))) + (case syntax + (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Lux/Monad + [expansion (macro args) + expansion' (M;map% Lux/Monad macro-expand expansion)] + (M;wrap (:: List/Monad (M;join expansion')))) + + #;None + (do Lux/Monad + [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] + (M;wrap (list (form$ (:: List/Monad (M;join parts')))))))) + + (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) + (do Lux/Monad + [harg+ (macro-expand harg) + targs+ (M;map% Lux/Monad macro-expand targs)] + (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+)))))))) + + (#;Meta [_ (#;TupleS members)]) + (do Lux/Monad + [members' (M;map% Lux/Monad macro-expand members)] + (M;wrap (list (tuple$ (:: List/Monad (M;join members')))))) + + _ + (:: Lux/Monad (M;wrap (list syntax))))) + +(def #export (gensym prefix state) + (-> Text (Lux Syntax)) + (#;Right [(update@ #;seed inc state) + (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed state)))])])) + +(def #export (emit datum) + (All [a] + (-> a (Lux a))) + (lambda [state] + (#;Right [state datum]))) + +(def #export (fail msg) + (All [a] + (-> Text (Lux a))) + (lambda [_] + (#;Left msg))) + +(def #export (macro-expand-1 token) + (-> Syntax (Lux Syntax)) + (do Lux/Monad + [token+ (macro-expand token)] + (case token+ + (\ (list token')) + (M;wrap token') + + _ + (fail "Macro expanded to more than 1 element.")))) + +(def #export (module-exists? module state) + (-> Text (Lux Bool)) + (#;Right [state (case (get module (get@ #;modules state)) + (#;Some _) + true + + #;None + false)])) + +(def #export (exported-defs module state) + (-> Text (Lux (List Text))) + (case (get module (get@ #;modules state)) + (#;Some =module) + (using List/Monad + (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) + (List Text)) + (lambda [gdef] + (let [[name [export? _]] gdef] + (if export? + (list name) + (list))))) + (get@ #;defs =module))))])) + + #;None + (#;Left ($ text:++ "Unknown module: " module)))) + +(def (show-envs envs) + (-> (List (Env Text (, LuxVar Type))) Text) + (|> envs + (F;map (lambda [env] + (case env + {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _} + ($ text:++ name ": " (|> locals + (F;map (: (All [a] (-> (, Text a) Text)) + (lambda [b] (let [[label _] b] label)))) + (:: List/Functor) + (interpose " ") + (foldL text:++ "")))))) + (:: List/Functor) + (interpose "\n") + (foldL text:++ ""))) + +(def (try-both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #;None (f x2) + (#;Some y) (#;Some y))) + +(def (find-in-env name state) + (-> Ident Compiler (Maybe Type)) + (let [vname' (ident->text name)] + (case state + {#;source source #;modules modules + #;envs envs #;types types #;host host + #;seed seed #;eval? eval?} + (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (lambda [env] + (case env + {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} + (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= vname' bname) + (#;Some type) + #;None))))) + locals + closure)))) + envs)))) + +(def (find-in-defs name state) + (-> Ident Compiler (Maybe Type)) + (let [[v-prefix v-name] name + {#;source source #;modules modules + #;envs envs #;types types #;host host + #;seed seed #;eval? eval?} state] + (case (get v-prefix modules) + #;None + #;None + + (#;Some {#;defs defs #;module-aliases _ #;imports _}) + (case (get v-name defs) + #;None + #;None + + (#;Some [_ def-data]) + (case def-data + #;TypeD (#;Some Type) + (#;ValueD type) (#;Some type) + (#;MacroD m) (#;Some Macro) + (#;AliasD name') (find-in-defs name' state)))))) + +(def #export (find-var-type name) + (-> Ident (Lux Type)) + (do Lux/Monad + [name' (normalize name)] + (: (Lux Type) + (lambda [state] + (case (find-in-env name state) + (#;Some struct-type) + (#;Right [state struct-type]) + + _ + (case (find-in-defs name' state) + (#;Some struct-type) + (#;Right [state struct-type]) + + _ + (let [{#;source source #;modules modules + #;envs envs #;types types #;host host + #;seed seed #;eval? eval?} state] + (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) + )) diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux new file mode 100644 index 000000000..22aeaf874 --- /dev/null +++ b/source/lux/meta/macro.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Utils] +(def (_meta x) + (-> (Syntax' (Meta Cursor)) Syntax) + (#;Meta [["" -1 -1] x])) + +## [Syntax] +(def #export (defmacro tokens state) + Macro + (case tokens + (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) + (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) + (~ (_meta (#;SymbolS ["lux" "Macro"]))) + (~ body))) + (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + #;Nil])])]) + + (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) + (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args)) + (~ (_meta (#;SymbolS ["lux" "Macro"]))) + (~ body))) + (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + #;Nil])])]) + + _ + (#;Left "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) + +## [Functions] +(do-template [ ] + [(def #export ( x) + (-> Syntax) + (#;Meta [["" -1 -1] ( x)]))] + + [bool$ Bool #;BoolS] + [int$ Int #;IntS] + [real$ Real #;RealS] + [char$ Char #;CharS] + [text$ Text #;TextS] + [symbol$ Ident #;SymbolS] + [tag$ Ident #;TagS] + [form$ (List Syntax) #;FormS] + [tuple$ (List Syntax) #;TupleS] + [record$ (List (, Syntax Syntax)) #;RecordS] + ) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux new file mode 100644 index 000000000..1fe85c32f --- /dev/null +++ b/source/lux/meta/syntax.lux @@ -0,0 +1,262 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. (macro #as m #refer #all) + (lux #as l #refer (#only Lux/Monad gensym))) + (lux (control (functor #as F) + (monad #as M #refer (#only do))) + (data (eq #as E) + (bool #as b) + (char #as c) + (text #as t) + list))) + +## [Utils] +(def (first xy) + (All [a b] (-> (, a b) a)) + (let [[x y] xy] + x)) + +(def (join-pairs pairs) + (All [a] (-> (List (, a a)) (List a))) + (case pairs + #;Nil #;Nil + (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) + +## Types +(deftype #export (Parser a) + (-> (List Syntax) (Maybe (, (List Syntax) a)))) + +## Structures +(defstruct #export Parser/Functor (F;Functor Parser) + (def (F;map f ma) + (lambda [tokens] + (case (ma tokens) + #;None + #;None + + (#;Some [tokens' a]) + (#;Some [tokens' (f a)]))))) + +(defstruct #export Parser/Monad (M;Monad Parser) + (def M;_functor Parser/Functor) + + (def (M;wrap x tokens) + (#;Some [tokens x])) + + (def (M;join mma) + (lambda [tokens] + (case (mma tokens) + #;None + #;None + + (#;Some [tokens' ma]) + (ma tokens'))))) + +## Parsers +(def #export (id^ tokens) + (Parser Syntax) + (case tokens + #;Nil #;None + (#;Cons [t tokens']) (#;Some [tokens' t]))) + +(do-template [ ] + [(def #export ( tokens) + (Parser ) + (case tokens + (#;Cons [(#;Meta [_ ( x)]) tokens']) + (#;Some [tokens' x]) + + _ + #;None))] + + [ bool^ Bool #;BoolS] + [ int^ Int #;IntS] + [ real^ Real #;RealS] + [ char^ Char #;CharS] + [ text^ Text #;TextS] + [symbol^ Ident #;SymbolS] + [ tag^ Ident #;TagS] + ) + +(do-template [ ] + [(def #export ( tokens) + (Parser Text) + (case tokens + (#;Cons [(#;Meta [_ ( ["" x])]) tokens']) + (#;Some [tokens' x]) + + _ + #;None))] + + [local-symbol^ #;SymbolS] + [ local-tag^ #;TagS] + ) + +(def (ident:= x y) + (-> Ident Ident Bool) + (let [[x1 x2] x + [y1 y2] y] + (and (text:= x1 y1) + (text:= x2 y2)))) + +(do-template [ ] + [(def #export ( v tokens) + (-> (Parser (,))) + (case tokens + (#;Cons [(#;Meta [_ ( x)]) tokens']) + (if ( v x) + (#;Some [tokens' []]) + #;None) + + _ + #;None))] + + [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)] + [ int?^ Int #;IntS i=] + [ real?^ Real #;RealS r=] + [ char?^ Char #;CharS (:: c;Char/Eq E;=)] + [ text?^ Text #;TextS (:: t;Text/Eq E;=)] + [symbol?^ Ident #;SymbolS ident:=] + [ tag?^ Ident #;TagS ident:=] + ) + +(do-template [ ] + [(def #export ( p tokens) + (All [a] + (-> (Parser a) (Parser a))) + (case tokens + (#;Cons [(#;Meta [_ ( form)]) tokens']) + (case (p form) + (#;Some [#;Nil x]) (#;Some [tokens' x]) + _ #;None) + + _ + #;None))] + + [ form^ #;FormS] + [tuple^ #;TupleS] + ) + +(def #export (?^ p tokens) + (All [a] + (-> (Parser a) (Parser (Maybe a)))) + (case (p tokens) + #;None (#;Some [tokens #;None]) + (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)]))) + +(def (run-parser p tokens) + (All [a] + (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a)))) + (p tokens)) + +(def #export (*^ p tokens) + (All [a] + (-> (Parser a) (Parser (List a)))) + (case (p tokens) + #;None (#;Some [tokens (list)]) + (#;Some [tokens' x]) (run-parser (do Parser/Monad + [xs (*^ p)] + (M;wrap (list& x xs))) + tokens'))) + +(def #export (+^ p) + (All [a] + (-> (Parser a) (Parser (List a)))) + (do Parser/Monad + [x p + xs (*^ p)] + (M;wrap (list& x xs)))) + +(def #export (&^ p1 p2) + (All [a b] + (-> (Parser a) (Parser b) (Parser (, a b)))) + (do Parser/Monad + [x1 p1 + x2 p2] + (M;wrap [x1 x2]))) + +(def #export (|^ p1 p2 tokens) + (All [a b] + (-> (Parser a) (Parser b) (Parser (Either b)))) + (case (p1 tokens) + (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) + #;None (run-parser (do Parser/Monad + [x2 p2] + (M;wrap (#;Right x2))) + tokens))) + +(def #export (||^ ps tokens) + (All [a] + (-> (List (Parser a)) (Parser (Maybe a)))) + (case ps + #;Nil #;None + (#;Cons [p ps']) (case (p tokens) + #;None (||^ ps' tokens) + (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)])) + )) + +(def #export (end^ tokens) + (Parser (,)) + (case tokens + #;Nil (#;Some [tokens []]) + _ #;None)) + +## Syntax +(defmacro #export (defsyntax tokens) + (let [[exported? tokens] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens]))] + (case tokens + (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) + body)) + (do Lux/Monad + [names+parsers (M;map% Lux/Monad + (: (-> Syntax (Lux (, Syntax Syntax))) + (lambda [arg] + (case arg + (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) + parser))])) + (M;wrap [(symbol$ var-name) parser]) + + (\ (#;Meta [_ (#;SymbolS var-name)])) + (M;wrap [(symbol$ var-name) (` id^)]) + + _ + (l;fail "Syntax pattern expects 2-tuples or symbols.")))) + args) + g!tokens (gensym "tokens") + g!_ (gensym "_") + #let [names (:: List/Functor (F;map first names+parsers)) + error-msg (text$ (text:++ "Wrong syntax for " name)) + body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body name+parser] + (let [[name parser] name+parser] + (` (_lux_case ((~ parser) (~ g!tokens)) + (#;Some [(~ g!tokens) (~ name)]) + (~ body) + + (~ g!_) + (l;fail (~ error-msg))))))) + body + (reverse names+parsers)) + macro-def (: Syntax + (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) + (~ body'))))]] + (M;wrap (list& macro-def + (if exported? + (list (` (_lux_export (~ (symbol$ ["" name]))))) + (list))))) + + _ + (l;fail "Wrong syntax for defsyntax")))) diff --git a/source/program.lux b/source/program.lux new file mode 100644 index 000000000..052c0bf41 --- /dev/null +++ b/source/program.lux @@ -0,0 +1,48 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (codata (stream #as S)) + (control monoid + functor + monad + lazy + comonad) + (data bool + bounded + char + ## cont + dict + (either #as e) + eq + error + id + io + list + maybe + number + ord + (reader #as r) + show + state + (text #as t) + writer) + (host java) + (meta lux + macro + syntax) + (math #as m) + )) + +(program args + (case args + #;Nil + (println "Hello, world!") + + (#;Cons [name _]) + (println ($ text:++ "Hello, " name "!")))) diff --git a/src/lux.clj b/src/lux.clj index 7ff8fda37..9c913c9ac 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -14,9 +14,7 @@ :reload-all)) (defn -main [& _] - (do (time (&compiler/compile-all (&/|list "lux" "program"))) - ;; (prn @&type/counter) - ) + (time (&compiler/compile-all (&/|list "lux" "program"))) (System/exit 0)) (comment diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 68bd627fc..e490bc62f 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -117,9 +117,9 @@ (defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args] (|do [=classes (&/map% &host/extract-jvm-param ?classes) =return (&host/lookup-static-method ?class ?method =classes) - :let [_ (matchv ::M/objects [=return] - [["lux;DataT" _return-class]] - (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] + ;; :let [_ (matchv ::M/objects [=return] + ;; [["lux;DataT" _return-class]] + ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] (&&/analyse-1 analyse (&/V "lux;DataT" _class) _arg)) =classes diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 6acae193f..b25dff9eb 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -394,7 +394,7 @@ (return nil))] (&/save-module (|do [already-compiled? (&&module/exists? ?path) - :let [_ (prn 'analyse-import module-name ?path already-compiled?)] + ;; :let [_ (prn 'analyse-import module-name ?path already-compiled?)] _ (&&module/add-import ?path) _ (&/when% (not already-compiled?) (compile-module ?path))] (return (&/|list)))))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 05ab12bf1..bb1c72f66 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -24,6 +24,7 @@ [lux.analyser.base :as &a] [lux.analyser.module :as &a-module] (lux.compiler [base :as &&] + [cache :as &&cache] [lux :as &&lux] [host :as &&host] [case :as &&case] @@ -369,12 +370,12 @@ return)))) (defn ^:private compile-module [name] - ;; (prn 'compile-module name (&&/cached? name)) - (let [file-name (str "input/" name ".lux") + ;; (prn 'compile-module name (&&cache/cached? name)) + (let [file-name (str &&/input-dir "/" name ".lux") file-content (slurp file-name) file-hash (hash file-content)] - (if (&&/cached? name) - (&&/load-cache name file-hash compile-module) + (if (&&cache/cached? name) + (&&cache/load name file-hash compile-module) (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] (&/map% compile-statement analysis+))] (|do [module-exists? (&a-module/exists? name)] @@ -416,31 +417,16 @@ (fail* ?message))))))) ))) -(defn ^:private clean-file [^java.io.File file] - (if (.isDirectory file) - (do (doseq [f (seq (.listFiles file))] - (clean-file f)) - (.delete file)) - (.delete file))) - -(defn ^:private setup-dirs! [] - (.mkdir (java.io.File. "cache")) - (.mkdir (java.io.File. "cache/jvm")) - (.mkdir (java.io.File. "output")) - (.mkdir (java.io.File. "output/jvm")) - (doseq [f (seq (.listFiles (java.io.File. "output/jvm")))] - (clean-file f))) +(defn ^:private init! [] + (.mkdirs (java.io.File. &&/output-dir))) ;; [Resources] (defn compile-all [modules] - (setup-dirs!) + (init!) (matchv ::M/objects [((&/map% compile-module modules) (&/init-state nil))] [["lux;Right" [?state _]]] - (println "Compilation complete!") + (do (println "Compilation complete!") + (&&cache/clean ?state)) [["lux;Left" ?message]] (assert false ?message))) - -(comment - (compile-all ["lux"]) - ) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index d3dfc8746..e7b338b16 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -25,43 +25,28 @@ FileOutputStream) (java.lang.reflect Field))) +;; [Constants] +(def ^String version "0.2") +(def ^String input-dir "source") +(def ^String output-dir "target/jvm") + +(def ^String local-prefix "l") +(def ^String partial-prefix "p") +(def ^String closure-prefix "c") +(def ^String apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") + ;; [Utils] (defn ^:private write-file [^String file ^bytes data] (with-open [stream (BufferedOutputStream. (FileOutputStream. file))] (.write stream data))) (defn ^:private write-output [module name data] - (let [module* (&host/->module-class module)] - (.mkdirs (File. (str "output/jvm/" module*))) - (write-file (str "output/jvm/" module* "/" name ".class") data))) - -(defn ^:private write-cache [module name data] - (let [module* (&host/->module-class module)] - (.mkdirs (File. (str "cache/jvm/" module*))) - (write-file (str "cache/jvm/" module* "/" name ".class") data))) - -(defn ^:private clean-file [^File file] - (if (.isDirectory file) - (do (doseq [f (seq (.listFiles file))] - (clean-file f)) - (.delete file)) - (.delete file))) - -(defn ^:private read-file [^File file] - (with-open [reader (io/input-stream file)] - (let [length (.length file) - buffer (byte-array length)] - (.read reader buffer 0 length) - buffer))) + (let [module* (&host/->module-class module) + module-dir (str output-dir "/" module*)] + (.mkdirs (File. module-dir)) + (write-file (str module-dir "/" name ".class") data))) ;; [Exports] -(def version "0.2") - -(def local-prefix "l") -(def partial-prefix "p") -(def closure-prefix "c") -(def apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") - (defn load-class! [^ClassLoader loader name] ;; (prn 'load-class! name) (.loadClass loader name)) @@ -75,104 +60,5 @@ _ (swap! !classes assoc real-name bytecode) _ (load-class! loader real-name) _ (when (not eval?) - (do (write-output module name bytecode) - (write-cache module name bytecode)))]] + (write-output module name bytecode))]] (return nil))) - -(defn cached? [module] - (.exists (File. (str "cache/jvm/" (&host/->module-class module) "/_.class")))) - -(defn delete-cache [module] - (fn [state] - (do (clean-file (File. (str "cache/jvm/" (&host/->module-class module)))) - (return* state nil)))) - -(defn ^:private replace-several [content & replacements] - (let [replacement-list (partition 2 replacements)] - (reduce #(try (let [[_pattern _rep] %2] - (string/replace %1 _pattern (string/re-quote-replacement _rep))) - (catch Exception e - (prn 'replace-several content %1 %2) - (throw e))) - content replacement-list))) - -(defn ^:private get-field [^String field-name ^Class class] - (-> class ^Field (.getField field-name) (.get nil)) - ;; (try (-> class ^Field (.getField field-name) (.get nil)) - ;; (catch Error e - ;; (assert false (prn-str 'get-field field-name class)))) - ) - -(defn load-cache [module module-hash compile-module] - (|do [loader &/loader - !classes &/classes - already-loaded? (&a-module/exists? module) - _modules &/modules - :let [redo-cache (|do [_ (delete-cache module) - _ (compile-module module)] - (return false))]] - (do (prn 'load-cache module 'sources already-loaded? - (&/->seq _modules)) - (if already-loaded? - (return true) - (if (cached? module) - (do (prn 'load-cache/HASH module module-hash) - (let [module* (&host/->module-class module) - module-path (str "cache/jvm/" module*) - class-name (str module* "._") - ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) - (load-class! loader class-name))] - (if (and (= module-hash (get-field "_hash" module-meta)) - (= version (get-field "_compiler" module-meta))) - (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") - _ (prn 'load-cache/IMPORTS module imports) - ] - (|do [loads (&/map% (fn [_import] - (load-cache _import (-> (str "input/" _import ".lux") slurp hash) compile-module)) - (if (= [""] imports) - (&/|list) - (&/->list imports)))] - (if (->> loads &/->seq (every? true?)) - (do (doseq [^File file (seq (.listFiles (File. module-path))) - :let [file-name (.getName file)] - :when (not= "_.class" file-name)] - (let [real-name (second (re-find #"^(.*)\.class$" file-name)) - bytecode (read-file file) - ;; _ (prn 'load-cache module real-name) - ] - (swap! !classes assoc (str module* "." real-name) bytecode) - (write-output module real-name bytecode))) - (let [defs (string/split (get-field "_defs" module-meta) #"\t")] - ;; (prn 'load-cache module defs) - (|do [_ (&a-module/enter-module module) - _ (&/map% (fn [_def] - (let [[_exported? _name _ann] (string/split _def #" ") - ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) - ] - (|do [_ (case _ann - "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) - "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &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) - def-type (get-field "_meta" def-class)] - (matchv ::M/objects [def-type] - [["lux;ValueD" _def-type]] - (&a-module/define module _name def-type _def-type))) - ;; else - (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] - (|do [__type (&a-module/def-type __module __name)] - (do ;; (prn '__type [__module __name] (&type/show-type __type)) - (&a-module/def-alias module _name __module __name __type)))))] - (if (= "1" _exported?) - (&a-module/export module _name) - (return nil))) - )) - (if (= [""] defs) - (&/|list) - (&/->list defs)))] - (return true)))) - redo-cache))) - redo-cache) - )) - redo-cache))))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj new file mode 100644 index 000000000..d6f0b1db7 --- /dev/null +++ b/src/lux/compiler/cache.clj @@ -0,0 +1,135 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.compiler.cache + (:refer-clojure :exclude [load]) + (:require [clojure.string :as string] + [clojure.java.io :as io] + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail*]] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &a] + [module :as &a-module]) + (lux.compiler [base :as &&])) + (:import (java.io File + BufferedOutputStream + FileOutputStream) + (java.lang.reflect Field))) + +;; [Utils] +(defn ^:private read-file [^File file] + (with-open [reader (io/input-stream file)] + (let [length (.length file) + buffer (byte-array length)] + (.read reader buffer 0 length) + buffer))) + +(defn ^:private clean-file [^File file] + (if (.isDirectory file) + (do (doseq [f (seq (.listFiles file))] + (clean-file f)) + (.delete file)) + (.delete file))) + +(defn ^:private get-field [^String field-name ^Class class] + (-> class ^Field (.getField field-name) (.get nil))) + +;; [Resources] +(defn cached? [module] + "(-> Text Bool)" + (.exists (new File (str &&/output-dir "/" (&host/->module-class module) "/_.class")))) + +(defn delete [module] + "(-> Text (Lux (,)))" + (fn [state] + (do (clean-file (new File (str &&/output-dir "/" (&host/->module-class module)))) + (return* state nil)))) + +(defn clean [state] + "(-> Compiler (,))" + (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set) + outdated? #(-> % .getName (string/replace " " "/") (->> (contains? needed-modules)) not) + outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?))] + (doseq [f outdate-files] + (clean-file f)) + nil)) + +(defn load [module module-hash compile-module] + (|do [loader &/loader + !classes &/classes + already-loaded? (&a-module/exists? module) + _modules &/modules + :let [redo-cache (|do [_ (delete module) + _ (compile-module module)] + (return false))]] + (do ;; (prn 'load module 'sources already-loaded? + ;; (&/->seq _modules)) + (if already-loaded? + (return true) + (if (cached? module) + (do ;; (prn 'load/HASH module module-hash) + (let [module* (&host/->module-class module) + module-path (str &&/output-dir "/" module*) + class-name (str module* "._") + ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (&&/load-class! loader class-name))] + (if (and (= module-hash (get-field "_hash" module-meta)) + (= &&/version (get-field "_compiler" module-meta))) + (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") + ;; _ (prn 'load/IMPORTS module imports) + ] + (|do [loads (&/map% (fn [_import] + (load _import (-> (str &&/input-dir "/" _import ".lux") slurp hash) compile-module)) + (if (= [""] imports) + (&/|list) + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (do (doseq [^File file (seq (.listFiles (File. module-path))) + :let [file-name (.getName file)] + :when (not= "_.class" file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) + bytecode (read-file file) + ;; _ (prn 'load module real-name) + ] + (swap! !classes assoc (str module* "." real-name) bytecode))) + (let [defs (string/split (get-field "_defs" module-meta) #"\t")] + ;; (prn 'load module defs) + (|do [_ (&a-module/enter-module module) + _ (&/map% (fn [_def] + (let [[_exported? _name _ann] (string/split _def #" ") + ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) + ] + (|do [_ (case _ann + "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) + "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &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) + def-type (get-field "_meta" def-class)] + (matchv ::M/objects [def-type] + [["lux;ValueD" _def-type]] + (&a-module/define module _name def-type _def-type))) + ;; else + (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] + (|do [__type (&a-module/def-type __module __name)] + (do ;; (prn '__type [__module __name] (&type/show-type __type)) + (&a-module/def-alias module _name __module __name __type)))))] + (if (= "1" _exported?) + (&a-module/export module _name) + (return nil))) + )) + (if (= [""] defs) + (&/|list) + (&/->list defs)))] + (return true)))) + redo-cache))) + redo-cache) + )) + redo-cache))))) -- cgit v1.2.3 From 9b7cfd6f5bcc93e2f2f0c3129b7ec6d62c69bb37 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Jul 2015 20:57:21 -0400 Subject: - Fixed a pattern-matching error where generalizations of types (universal-quantification / AllT) was not being taken into account properly when destructuring. - Fixed a compiler error wherein the types of definitions didn't generate (correctly) the structures necessary for storage inside the class _meta(data) field. - Improved both the "open" and "import" macros with extra features. --- source/lux.lux | 117 ++++++++++++++++++++++++++++-------------- source/lux/data/char.lux | 3 +- source/lux/data/io.lux | 3 +- source/lux/data/number.lux | 8 +-- source/lux/host/java.lux | 84 +++++++++++++++---------------- source/lux/meta/lux.lux | 7 +-- source/lux/meta/syntax.lux | 2 +- source/program.lux | 2 +- src/lux/analyser/case.clj | 120 ++++++++++++++++++++++++++++++++++++-------- src/lux/analyser/lux.clj | 18 ++++--- src/lux/compiler/base.clj | 1 + src/lux/compiler/cache.clj | 2 +- src/lux/compiler/host.clj | 2 +- src/lux/compiler/lambda.clj | 2 +- src/lux/compiler/lux.clj | 113 ++++------------------------------------- src/lux/compiler/type.clj | 97 +++++++++++++++++++++++++++++++++++ src/lux/type.clj | 20 ++++++-- 17 files changed, 367 insertions(+), 234 deletions(-) create mode 100644 src/lux/compiler/type.clj diff --git a/source/lux.lux b/source/lux.lux index 50f8f1af2..8f7e4fa04 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1069,7 +1069,7 @@ _ #Nil)) -(def'' #export (text:= x y) +(def'' (text:= x y) (-> Text Text Bool) (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] x [y])) @@ -1196,7 +1196,7 @@ (-> Bool Bool) (if x false true)) -(def'' #export (text:++ x y) +(def'' (text:++ x y) (-> Text Text Text) (_jvm_invokevirtual java.lang.String concat [java.lang.String] x [y])) @@ -1883,8 +1883,11 @@ (#Exclude (List Text)) #Nothing)) +(deftype Openings + (, Text (List Ident))) + (deftype Import - (, Text (Maybe Text) Referrals)) + (, Text (Maybe Text) Referrals (Maybe Openings))) (def (extract-defs defs) (-> (List Syntax) (Lux (List Text))) @@ -1932,6 +1935,26 @@ _ (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) +(def (extract-symbol syntax) + (-> Syntax (Lux Ident)) + (case syntax + (#Meta [_ (#SymbolS ident)]) + (return ident) + + _ + (fail "Not a symbol."))) + +(def (parse-openings tokens) + (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax)))) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "open"])]) (#Meta [_ (#FormS (list& (#Meta [_ (#TextS prefix)]) structs))]) tokens')) + (do Lux/Monad + [structs' (map% Lux/Monad extract-symbol structs)] + (return (: (, (Maybe Openings) (List Syntax)) [(#Some [prefix structs']) tokens']))) + + _ + (return (: (, (Maybe Openings) (List Syntax)) [#None tokens])))) + (def (decorate-imports super-name tokens) (-> Text (List Syntax) (Lux (List Syntax))) (map% Lux/Monad @@ -1951,33 +1974,31 @@ (def (parse-imports imports) (-> (List Syntax) (Lux (List Import))) (do Lux/Monad - [referrals' (map% Lux/Monad - (: (-> Syntax (Lux (List Import))) - (lambda [token] - (case token - (#Meta [_ (#SymbolS ["" m-name])]) - (;return (list [m-name #None #All])) - - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) - (do Lux/Monad - [alias+extra' (parse-alias extra) - #let [[alias extra'] (: (, (Maybe Text) (List Syntax)) - alias+extra')] - referral+extra'' (parse-referrals extra') - #let [[referral extra''] (: (, Referrals (List Syntax)) - referral+extra'')] - extra''' (decorate-imports m-name extra'') - sub-imports (parse-imports extra''')] - (;return (case referral - #Nothing (case alias - #None sub-imports - (#Some _) (list& [m-name alias referral] sub-imports)) - _ (list& [m-name alias referral] sub-imports)))) - - _ - (fail "Wrong syntax for import")))) - imports)] - (;return (list:join referrals')))) + [imports' (map% Lux/Monad + (: (-> Syntax (Lux (List Import))) + (lambda [token] + (case token + (#Meta [_ (#SymbolS ["" m-name])]) + (;return (list [m-name #None #All #None])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) + (do Lux/Monad + [alias+extra (parse-alias extra) + #let [[alias extra] alias+extra] + referral+extra (parse-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-openings extra) + #let [[openings extra] openings+extra] + extra (decorate-imports m-name extra) + sub-imports (parse-imports extra)] + (;return (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings]) + [#Nothing #None #None] sub-imports + _ (list& [m-name alias referral openings] sub-imports)))) + + _ + (fail "Wrong syntax for import")))) + imports)] + (;return (list:join imports')))) (def (module-exists? module state) (-> Text (Lux Bool)) @@ -2131,16 +2152,16 @@ (: (-> Import (Lux Import)) (lambda [import] (case import - [m-name m-alias m-referrals] + [m-name m-alias m-referrals m-openings] (do Lux/Monad [m-name (clean-module m-name)] - (;return (: Import [m-name m-alias m-referrals])))))) + (;return (: Import [m-name m-alias m-referrals m-openings])))))) imports) unknowns' (map% Lux/Monad (: (-> Import (Lux (List Text))) (lambda [import] (case import - [m-name _ _] + [m-name _ _ _] (do Lux/Monad [? (module-exists? m-name)] (;return (if ? @@ -2155,7 +2176,7 @@ (: (-> Import (Lux (List Syntax))) (lambda [import] (case import - [m-name m-alias m-referrals] + [m-name m-alias m-referrals m-openings] (do Lux/Monad [defs (case m-referrals #All @@ -2172,7 +2193,18 @@ (;return (filter (. not (is-member? -defs)) *defs))) #Nothing - (;return (list)))] + (;return (list))) + #let [openings (: (List Syntax) + (case m-openings + #None + (list) + + (#Some [prefix structs]) + (map (: (-> Ident Syntax) + (lambda [struct] + (let [[_ name] struct] + (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) + structs)))]] (;return ($ list:++ (list (` (_lux_import (~ (text$ m-name))))) (case m-alias @@ -2181,7 +2213,8 @@ (map (: (-> Text Syntax) (lambda [def] (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) - defs))))))) + defs) + openings)))))) imports)] (;return (list:join output'))) @@ -2583,16 +2616,22 @@ (defmacro #export (open tokens) (case tokens - (\ (list (#Meta [_ (#SymbolS struct-name)]))) + (\ (list& (#Meta [_ (#SymbolS struct-name)]) tokens')) (do Lux/Monad - [struct-type (find-var-type struct-name)] + [#let [prefix (case tokens' + (\ (list (#Meta [_ (#TextS prefix)]))) + prefix + + _ + "")] + struct-type (find-var-type struct-name)] (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) (return (map (: (-> (, Text Type) Syntax) (lambda [slot] (let [[sname stype] slot [module name] (split-slot sname)] - (` (_lux_def (~ (symbol$ ["" name])) + (` (_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name)))))))) slots)) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index 42e57509e..5dac9a3c7 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -8,7 +8,8 @@ (;import lux (.. (eq #as E) - (show #as S))) + (show #as S) + (text #as T #open ("text:" Text/Monoid)))) ## [Structures] (defstruct #export Char/Eq (E;Eq Char) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index c08023df5..17e8d727a 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -10,7 +10,8 @@ (lux/meta macro) (lux/control (functor #as F) (monad #as M)) - lux/data/list) + (.. list + (text #as T #open ("text:" Text/Monoid)))) ## Types (deftype #export (IO a) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux index 8da674d88..b222de15c 100644 --- a/source/lux/data/number.lux +++ b/source/lux/data/number.lux @@ -8,10 +8,10 @@ (;import lux (lux/control (monoid #as m)) - (lux/data (eq #as E) - (ord #as O) - (bounded #as B) - (show #as S))) + (.. (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) ## Signatures (defsig #export (Number n) diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux index 12525d3f2..9bd0c838c 100644 --- a/source/lux/host/java.lux +++ b/source/lux/host/java.lux @@ -10,14 +10,12 @@ (lux (control (monoid #as m) (functor #as F) (monad #as M #refer (#only do))) - (data list + (data (list #as l #refer #all #open ("" List/Functor)) (text #as text)) (meta lux macro syntax))) -## (open List/Functor) - ## [Utils/Parsers] (def finally^ (Parser Syntax) @@ -110,29 +108,29 @@ (defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) (emit (list (` (_jvm_try (~ body) - (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax) - (lambda [catch] - (let [[class ex body] catch] - (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches)) - (case finally - #;None - (list) - - (#;Some finally) - (list (` (_jvm_finally (~ finally)))))))))))) + (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident Syntax) Syntax) + (lambda [catch] + (let [[class ex body] catch] + (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches) + (case finally + #;None + (list) + + (#;Some finally) + (list (` (_jvm_finally (~ finally))))))))))))) (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) (do Lux/Monad [current-module get-module-name #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) name))]] - (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) - members))] - (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))] + (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) + members)] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (map text$ supers))] (~@ members')))))))) (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] @@ -142,35 +140,35 @@ [current-module get-module-name #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) name)) - fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (symbol$ ["" name])) - (~ (text$ class)) - [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) - fields)) - methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (symbol$ ["" name])) - [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) - (lambda [in] - (let [[left right] in] - (form$ (list (text$ left) - (text$ right)))))) - inputs)))] - (~ (text$ output)) - [(~@ (:: List/Functor (F;map text$ modifiers)))] - (~ body)))))) - methods))]] + fields' (map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" name])) + (~ (text$ class)) + [(~@ (map text$ modifiers))]))))) + fields) + methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (symbol$ ["" name])) + [(~@ (map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs))] + (~ (text$ output)) + [(~@ (map text$ modifiers))] + (~ body)))))) + methods)]] (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) - [(~@ (:: List/Functor (F;map text$ interfaces)))] + [(~@ (map text$ interfaces))] [(~@ fields')] [(~@ methods')])))))) (defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) (emit (list (` (_jvm_new (~ (text$ class)) - [(~@ (:: List/Functor (F;map text$ arg-classes)))] + [(~@ (map text$ arg-classes))] [(~@ args)]))))) (defsyntax #export (instance? [class local-symbol^] obj) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index a28d6e5d4..99ca200cf 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -14,7 +14,8 @@ (lux/data list maybe (show #as S) - (number #as N))) + (number #as N) + (text #as T #open ("text:" Text/Monoid Text/Eq)))) ## [Types] ## (deftype (Lux a) @@ -209,10 +210,10 @@ (lambda [b] (let [[label _] b] label)))) (:: List/Functor) (interpose " ") - (foldL text:++ "")))))) + (foldL text:++ text:unit)))))) (:: List/Functor) (interpose "\n") - (foldL text:++ ""))) + (foldL text:++ text:unit))) (def (try-both f x1 x2) (All [a b] diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 1fe85c32f..83702f75d 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -14,7 +14,7 @@ (data (eq #as E) (bool #as b) (char #as c) - (text #as t) + (text #as t #open ("text:" Text/Monoid Text/Eq)) list))) ## [Utils] diff --git a/source/program.lux b/source/program.lux index 052c0bf41..18a2a76ab 100644 --- a/source/program.lux +++ b/source/program.lux @@ -30,7 +30,7 @@ (reader #as r) show state - (text #as t) + (text #as t #open ("text:" Text/Monoid)) writer) (host java) (meta lux diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 659b2b0f6..cb76d8d54 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -23,7 +23,8 @@ (fail "##9##")))] (resolve-type type*)) - [["lux;AllT" ?id]] + [["lux;AllT" [_aenv _aname _aarg _abody]]] + ;; (&type/actual-type _abody) (|do [$var &type/existential =type (&type/apply-type type $var)] (&type/actual-type =type)) @@ -35,6 +36,79 @@ [_] (&type/actual-type type))) +(defn adjust-type* [up type] + "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + (matchv ::M/objects [type] + [["lux;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)))) + + [["lux;TupleT" ?members]] + (|do [["lux;TupleT" ?members*] (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] + (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V "lux;TupleT" (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + [["lux;RecordT" ?fields]] + (|do [["lux;RecordT" ?fields*] (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] + (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V "lux;RecordT" (&/|map (fn [kv] + (|let [[k v] kv] + (&/T k (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) + v + up)))) + ?fields*)))) + + [["lux;VariantT" ?cases]] + (|do [["lux;VariantT" ?cases*] (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] + (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V "lux;VariantT" (&/|map (fn [kv] + (|let [[k v] kv] + (&/T k (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) + v + up)))) + ?cases*)))) + + [["lux;AppT" [?tfun ?targ]]] + (|do [=type (&type/apply-type ?tfun ?targ)] + (adjust-type* up =type)) + + [["lux;VarT" ?id]] + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail "##9##")))] + (adjust-type* up type*)) + + [_] + (assert false (aget type 0)) + )) + +(defn adjust-type [type] + "(-> Type (Lux Type))" + (adjust-type* (&/|list) type)) + (defn ^:private analyse-pattern [value-type pattern kont] (matchv ::M/objects [pattern] [["lux;Meta" [_ pattern*]]] @@ -71,27 +145,31 @@ (return (&/T (&/V "TextTestAC" ?value) =kont))) [["lux;TupleS" ?members]] - (|do [value-type* (resolve-type value-type)] + (|do [value-type* (adjust-type value-type)] (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) - (matchv ::M/objects [value-type*] - [["lux;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*)))))) + (matchv ::M/objects [value-type*] + [["lux;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*)))))) [["lux;RecordS" ?slots]] - (|do [value-type* (resolve-type value-type)] + (|do [;; :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) + ] (matchv ::M/objects [value-type*] [["lux;RecordT" ?slot-types]] (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) @@ -118,7 +196,7 @@ [["lux;TagS" ?ident]] (|do [=tag (&&/resolved-ident ?ident) - value-type* (resolve-type value-type) + value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list)))) @@ -129,7 +207,7 @@ ["lux;Cons" [?value ["lux;Nil" _]]]]]]] (|do [=tag (&&/resolved-ident ?ident) - value-type* (resolve-type value-type) + value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) [=test =kont] (analyse-pattern case-type ?value kont)] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index b25dff9eb..4a912f1c1 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -219,7 +219,7 @@ [["lux;Cons" [?arg ?args*]]] (|do [?fun-type* (&type/actual-type fun-type)] (matchv ::M/objects [?fun-type*] - [["lux;AllT" _]] + [["lux;AllT" [_aenv _aname _aarg _abody]]] ;; (|do [$var &type/existential ;; type* (&type/apply-type ?fun-type* $var)] ;; (analyse-apply* analyse exo-type type* ?args)) @@ -230,11 +230,10 @@ (matchv ::M/objects [$var] [["lux;VarT" ?id]] (|do [? (&type/bound? ?id) - _ (if ? - (return nil) - (|do [ex &type/existential] - (&type/set-var ?id ex))) - type** (&type/clean $var =output-t)] + type** (if ? + (&type/clean $var =output-t) + (|do [_ (&type/set-var ?id (&/V "lux;BoundT" _aarg))] + (&type/clean $var =output-t)))] (return (&/T type** =args))) )))) @@ -262,11 +261,11 @@ (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] ;; :let [_ (when (and ;; (= "lux/control/monad" ?module) - ;; (= "case" ?name)) + ;; (= "open" ?name)) ;; (->> (&/|map &/show-ast macro-expansion*) ;; (&/|interpose "\n") ;; (&/fold str "") - ;; (prn ?module "case")))] + ;; (prn ?module "open")))] ] (&/flat-map% (partial analyse exo-type) macro-expansion*)) @@ -328,6 +327,9 @@ ;; dtype* (&type/actual-type dtype) ] (matchv ::M/objects [dtype] + [["lux;BoundT" ?vname]] + (return (&/T _expr exo-type)) + [["lux;ExT" _]] (return (&/T _expr exo-type)) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index e7b338b16..0631f51e8 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -29,6 +29,7 @@ (def ^String version "0.2") (def ^String input-dir "source") (def ^String output-dir "target/jvm") +(def ^String function-class "lux/Function") (def ^String local-prefix "l") (def ^String partial-prefix "p") diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index d6f0b1db7..57e81a2b0 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -55,7 +55,7 @@ (defn clean [state] "(-> Compiler (,))" (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set) - outdated? #(-> % .getName (string/replace " " "/") (->> (contains? needed-modules)) not) + outdated? #(-> ^File % .getName (string/replace " " "/") (->> (contains? needed-modules)) not) outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?))] (doseq [f outdate-files] (clean-file f)) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index fd34a45a7..3df09b29e 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -593,7 +593,7 @@ _ (compile ?body) :let [_ (doto main-writer (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature))] + (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature))] :let [_ (doto main-writer (.visitInsn Opcodes/POP) (.visitInsn Opcodes/RETURN) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index d97cc1f26..ccd12e68a 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -97,7 +97,7 @@ class-name (str (&host/->module-class (&/|head ?scope)) "/" name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - class-name nil "java/lang/Object" (into-array ["lux/Function"])) + class-name nil "java/lang/Object" (into-array [&&/function-class])) (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 32a7af751..f1c261d6b 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -21,7 +21,8 @@ (lux.analyser [base :as &a] [module :as &a-module]) (lux.compiler [base :as &&] - [lambda :as &&lambda])) + [lambda :as &&lambda] + [type :as &&type])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -63,7 +64,10 @@ (|do [:let [_ (doto *writer* (.visitInsn Opcodes/DUP) (.visitLdcInsn (int idx)))] - ret (compile elem) + ret (try (compile elem) + (catch Exception e + (prn 'compile-tuple (aget elem 0) (->> ?elems (&/|map #(aget % 0)) &/->seq)) + (throw e))) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return ret))) (&/|range num-elems) ?elems)] @@ -130,110 +134,11 @@ _ (compile ?fn) _ (&/map% (fn [?arg] (|do [=arg (compile ?arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "lux/Function" "apply" &&/apply-signature)]] + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature)]] (return =arg))) ?args)] (return nil))) -(defn ^:private type->analysis [type] - (matchv ::M/objects [type] - [["lux;DataT" ?class]] - (&/T (&/V "variant" (&/T "lux;DataT" - (&/T (&/V "text" ?class) &type/$Void))) - &type/$Void) - - [["lux;TupleT" ?members]] - (&/T (&/V "variant" (&/T "lux;TupleT" - (&/fold (fn [tail head] - (&/V "variant" (&/T "lux;Cons" - (&/T (&/V "tuple" (&/|list (type->analysis head) - tail)) - &type/$Void)))) - (&/V "variant" (&/T "lux;Nil" - (&/T (&/V "tuple" (&/|list)) - &type/$Void))) - (&/|reverse ?members)))) - &type/$Void) - - [["lux;VariantT" ?cases]] - (&/T (&/V "variant" (&/T "lux;VariantT" - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (&/V "variant" (&/T "lux;Cons" - (&/T (&/V "tuple" (&/|list (&/T (&/V "tuple" (&/|list (&/T (&/V "text" hlabel) &type/$Void) - (type->analysis htype))) - &type/$Void) - tail)) - &type/$Void))))) - (&/V "variant" (&/T "lux;Nil" - (&/T (&/V "tuple" (&/|list)) - &type/$Void))) - (&/|reverse ?cases)))) - &type/$Void) - - [["lux;RecordT" ?slots]] - (&/T (&/V "variant" (&/T "lux;RecordT" - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (&/V "variant" (&/T "lux;Cons" - (&/T (&/V "tuple" (&/|list (&/T (&/V "tuple" (&/|list (&/T (&/V "text" hlabel) &type/$Void) - (type->analysis htype))) - &type/$Void) - tail)) - &type/$Void))))) - (&/V "variant" (&/T "lux;Nil" - (&/T (&/V "tuple" (&/|list)) - &type/$Void))) - (&/|reverse ?slots)))) - &type/$Void) - - [["lux;LambdaT" [?input ?output]]] - (&/T (&/V "variant" (&/T "lux;LambdaT" - (&/T (&/V "tuple" (&/|map type->analysis (&/|list ?input ?output))) - &type/$Void))) - &type/$Void) - - [["lux;AllT" [?env ?name ?arg ?body]]] - (&/T (&/V "variant" (&/T "lux;AllT" - (&/T (&/V "tuple" (&/|list (matchv ::M/objects [?env] - [["lux;None" _]] - (&/V "variant" (&/T "lux;Some" - (&/T (&/V "tuple" (&/|list)) - &type/$Void))) - - [["lux;Some" ??env]] - (&/V "variant" (&/T "lux;Some" - (&/T (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (&/V "variant" (&/T "lux;Cons" - (&/T (&/V "tuple" (&/|list (&/T (&/V "tuple" (&/|list (&/T (&/V "text" hlabel) &type/$Void) - (type->analysis htype))) - &type/$Void) - tail)) - &type/$Void))))) - (&/V "variant" (&/T "lux;Nil" - (&/T (&/V "tuple" (&/|list)) - &type/$Void))) - (&/|reverse ??env)) - &type/$Void)))) - (&/T (&/V "text" ?name) &type/$Void) - (&/T (&/V "text" ?arg) &type/$Void) - (type->analysis ?body))) - &type/$Void))) - &type/$Void) - - [["lux;BoundT" ?name]] - (&/T (&/V "variant" (&/T "lux;BoundT" - (&/T (&/V "text" ?name) &type/$Void))) - &type/$Void) - - [["lux;AppT" [?fun ?arg]]] - (&/T (&/V "variant" (&/T "lux;AppT" - (&/T (&/V "tuple" (&/|map type->analysis (&/|list ?fun ?arg))) - &type/$Void))) - &type/$Void) - )) - (defn ^:private compile-def-type [compile ?body ?def-data] (|do [^MethodVisitor **writer** &/get-writer] (matchv ::M/objects [?def-data] @@ -260,7 +165,7 @@ (&/T ?def-value ?type-expr) [[?def-value ?def-type]] - (&/T ?body (type->analysis ?def-type)))] + (&/T ?body (&&type/->analysis ?def-type)))] (|do [:let [_ (doto **writer** (.visitLdcInsn (int 2)) ;; S (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V @@ -284,7 +189,7 @@ current-class (str (&host/->module-class module-name) "/" def-name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - current-class nil "java/lang/Object" (into-array ["lux/Function"])) + current-class nil "java/lang/Object" (into-array [&&/function-class])) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_name" "Ljava/lang/String;" nil ?name) (doto (.visitEnd))) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj new file mode 100644 index 000000000..a92911444 --- /dev/null +++ b/src/lux/compiler/type.clj @@ -0,0 +1,97 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.compiler.type + (:require [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* |let]] + [type :as &type]))) + +;; [Utils] +(defn ^:private variant$ [tag body] + "(-> Text Analysis Analysis)" + (&/T (&/V "variant" (&/T tag body)) + &type/$Void)) + +(defn ^:private tuple$ [members] + "(-> (List Analysis) Analysis)" + (&/T (&/V "tuple" members) + &type/$Void)) + +(defn ^:private text$ [text] + "(-> Text Analysis)" + (&/T (&/V "text" text) + &type/$Void)) + +(def ^:private $Nil + "Analysis" + (variant$ "lux;Nil" (tuple$ (&/|list)))) + +(defn ^:private Cons$ [head tail] + "(-> Analysis Analysis Analysis)" + (variant$ "lux;Cons" (tuple$ (&/|list head tail)))) + +;; [Exports] +(defn ->analysis [type] + "(-> Type Analysis)" + (matchv ::M/objects [type] + [["lux;DataT" ?class]] + (variant$ "lux;DataT" (text$ ?class)) + + [["lux;TupleT" ?members]] + (variant$ "lux;TupleT" + (&/fold (fn [tail head] + (Cons$ (->analysis head) tail)) + $Nil + (&/|reverse ?members))) + + [["lux;VariantT" ?cases]] + (variant$ "lux;VariantT" + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ?cases))) + + [["lux;RecordT" ?slots]] + (variant$ "lux;RecordT" + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ?slots))) + + [["lux;LambdaT" [?input ?output]]] + (variant$ "lux;LambdaT" (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) + + [["lux;AllT" [?env ?name ?arg ?body]]] + (variant$ "lux;AllT" + (tuple$ (&/|list (matchv ::M/objects [?env] + [["lux;None" _]] + (variant$ "lux;Some" (tuple$ (&/|list))) + + [["lux;Some" ??env]] + (variant$ "lux;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)))) + + [["lux;BoundT" ?name]] + (variant$ "lux;BoundT" (text$ ?name)) + + [["lux;AppT" [?fun ?arg]]] + (variant$ "lux;AppT" (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + )) diff --git a/src/lux/type.clj b/src/lux/type.clj index f1a5b7623..af2bbf30f 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -284,7 +284,7 @@ _ (&/map% delete-var (&/|reverse =vars))] (return output))) -(defn ^:private clean* [?tid type] +(defn clean* [?tid type] (matchv ::M/objects [type] [["lux;VarT" ?id]] (if (.equals ^Object ?tid ?id) @@ -345,6 +345,15 @@ [_] (fail (str "[Type Error] Not type-var: " (show-type tvar))))) +(defn ^:private unravel-fun [type] + (matchv ::M/objects [type] + [["lux;LambdaT" [?in ?out]]] + (|let [[??out ?args] (unravel-fun ?out)] + (&/T ??out (&/|cons ?in ?args))) + + [_] + (&/T type (&/|list)))) + (defn ^:private unravel-app [fun-type] (matchv ::M/objects [fun-type] [["lux;AppT" [?left ?right]]] @@ -389,17 +398,18 @@ (&/fold str "")) ")") [["lux;LambdaT" [input output]]] - (str "(-> " (show-type input) " " (show-type output) ")") + (|let [[?out ?ins] (unravel-fun type)] + (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) [["lux;VarT" id]] (str "⌈" id "⌋") - [["lux;BoundT" name]] - name - [["lux;ExT" ?id]] (str "⟨" ?id "⟩") + [["lux;BoundT" name]] + name + [["lux;AppT" [_ _]]] (|let [[?call-fun ?call-args] (unravel-app type)] (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) -- cgit v1.2.3 From 8fb7683f9029127be9cf36336c367813c88f681b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Jul 2015 23:09:47 -0400 Subject: - Changed the name of lux/host/java to lux/host/jvm - Completed lux/host/jvm - Modified (slightly) the syntax used in several host (JVM) special forms. - The "defsyntax" macro now binds all of the arguments it receives inside a variable named "tokens". --- source/lux.lux | 27 ++-- source/lux/data/char.lux | 2 +- source/lux/data/io.lux | 4 +- source/lux/data/number.lux | 14 +- source/lux/data/text.lux | 61 ++++----- source/lux/host/java.lux | 310 --------------------------------------------- source/lux/host/jvm.lux | 270 +++++++++++++++++++++++++++++++++++++++ source/lux/math.lux | 50 ++++---- source/lux/meta/syntax.lux | 2 +- source/program.lux | 2 +- src/lux/analyser.clj | 38 +++--- src/lux/analyser/case.clj | 4 +- src/lux/analyser/host.clj | 22 +--- src/lux/compiler/lux.clj | 5 +- src/lux/host.clj | 8 -- 15 files changed, 375 insertions(+), 444 deletions(-) delete mode 100644 source/lux/host/java.lux create mode 100644 source/lux/host/jvm.lux diff --git a/source/lux.lux b/source/lux.lux index 8f7e4fa04..c51929635 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -8,7 +8,7 @@ ## First things first, must define functions (_jvm_interface "Function" [] - (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) ## Basic types (_lux_def Bool (#DataT "java.lang.Boolean")) @@ -860,8 +860,9 @@ [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] unquoted - [_ (#Meta [_ (#FormS elems)])] - (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) + [_ (#Meta [meta (#FormS elems)])] + (let [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] + (#Meta [meta form'])) [_ (#Meta [_ (#RecordS fields)])] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) @@ -1071,7 +1072,7 @@ (def'' (text:= x y) (-> Text Text Bool) - (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y])) (def'' (get-rep key env) @@ -1146,9 +1147,9 @@ (-> Bool) ( x y))] - [i= _jvm_leq Int] - [i> _jvm_lgt Int] - [i< _jvm_llt Int] + [i= _jvm_leq Int] + [i> _jvm_lgt Int] + [i< _jvm_llt Int] [r= _jvm_deq Real] [r> _jvm_dgt Real] [r< _jvm_dlt Real] @@ -1198,7 +1199,7 @@ (def'' (text:++ x y) (-> Text Text Text) - (_jvm_invokevirtual java.lang.String concat [java.lang.String] + (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] x [y])) (def'' (ident->text ident) @@ -1396,7 +1397,7 @@ (def'' #export (->text x) (-> (^ java.lang.Object) Text) - (_jvm_invokevirtual java.lang.Object toString [] x [])) + (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) (def'' (interpose sep xs) (All [a] @@ -2039,22 +2040,22 @@ (def (last-index-of part text) (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String lastIndexOf [java.lang.String] + (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "lastIndexOf" ["java.lang.String"] text [part]))) (def (index-of part text) (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String] + (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "indexOf" ["java.lang.String"] text [part]))) (def (substring1 idx text) (-> Int Text Text) - (_jvm_invokevirtual java.lang.String substring [int] + (_jvm_invokevirtual "java.lang.String" "substring" ["int"] text [(_jvm_l2i idx)])) (def (substring2 idx1 idx2 text) (-> Int Int Text Text) - (_jvm_invokevirtual java.lang.String substring [int int] + (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) (def (split-module-contexts module) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index 5dac9a3c7..5a811c006 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -18,4 +18,4 @@ (defstruct #export Char/Show (S;Show Char) (def (S;show x) - ($ text:++ "#\"" (_jvm_invokevirtual java.lang.Object toString [] x []) "\""))) + ($ text:++ "#\"" (_jvm_invokevirtual "java.lang.Object" "toString" [] x []) "\""))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index 17e8d727a..a194fc854 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -44,8 +44,8 @@ ## Functions (def #export (print x) (-> Text (IO (,))) - (io (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) [x]))) + (io (_jvm_invokevirtual "java.io.PrintStream" "print" ["java.lang.Object"] + (_jvm_getstatic "java.lang.System" "out") [x]))) (def #export (println x) (-> Text (IO (,))) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux index b222de15c..453c30a13 100644 --- a/source/lux/data/number.lux +++ b/source/lux/data/number.lux @@ -62,12 +62,6 @@ (def E;= r=)) ## Ord -## (def #export Int/Ord (O;Ord Int) -## (O;ord$ Int/Eq i< i>)) - -## (def #export Real/Ord (O;Ord Real) -## (O;ord$ Real/Eq r< r>)) - (do-template [ ] [(defstruct #export (O;Ord ) (def O;_eq ) @@ -89,8 +83,8 @@ (def B;top ) (def B;bottom ))] - [ Int/Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] - [Real/Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) + [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")] + [Real/Bounded Real (_jvm_getstatic "java.lang.Double" "MAX_VALUE") (_jvm_getstatic "java.lang.Double" "MIN_VALUE")]) ## Monoid (do-template [ <++>] @@ -114,6 +108,6 @@ (def (S;show x) ))] - [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] - [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] + [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] + [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] ) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index a3192a1d5..f7f1a86c0 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -15,30 +15,30 @@ ## [Functions] (def #export (size x) (-> Text Int) - (_jvm_i2l (_jvm_invokevirtual java.lang.String length [] + (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "length" [] x []))) (def #export (@ idx x) (-> Int Text (Maybe Char)) (if (and (i< idx (size x)) (i>= idx 0)) - (#;Some (_jvm_invokevirtual java.lang.String charAt [int] + (#;Some (_jvm_invokevirtual "java.lang.String" "charAt" ["int"] x [(_jvm_l2i idx)])) #;None)) (def #export (contains? x y) (-> Text Text Bool) - (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence] + (_jvm_invokevirtual "java.lang.String" "contains" ["java.lang.CharSequence"] x [y])) (do-template [ ] [(def #export ( x) (-> Text Text) - (_jvm_invokevirtual java.lang.String [] + (_jvm_invokevirtual "java.lang.String" [] x []))] - [lower-case toLowerCase] - [upper-case toUpperCase] - [trim trim] + [lower-case "toLowerCase"] + [upper-case "toUpperCase"] + [trim "trim"] ) (def #export (sub' from to x) @@ -46,7 +46,7 @@ (if (and (i< from to) (i>= from 0) (i<= to (size x))) - (_jvm_invokevirtual java.lang.String substring [int int] + (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] x [(_jvm_l2i from) (_jvm_l2i to)]) #;None)) @@ -58,23 +58,23 @@ (-> Int Text (Maybe (, Text Text))) (if (and (i< at (size x)) (i>= at 0)) - (let [pre (_jvm_invokevirtual java.lang.String substring [int int] + (let [pre (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] x [(_jvm_l2i 0) (_jvm_l2i at)]) - post (_jvm_invokevirtual java.lang.String substring [int] + post (_jvm_invokevirtual "java.lang.String" "substring" ["int"] x [(_jvm_l2i at)])] (#;Some [pre post])) #;None)) (def #export (replace pattern value template) (-> Text Text Text Text) - (_jvm_invokevirtual java.lang.String replace [java.lang.CharSequence java.lang.CharSequence] + (_jvm_invokevirtual "java.lang.String" "replace" ["java.lang.CharSequence" "java.lang.CharSequence"] template [pattern value])) (do-template [ ] [(def #export ( pattern from x) (-> Text Int Text (Maybe Int)) (if (and (i< from (size x)) (i>= from 0)) - (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String int] + (case (_jvm_i2l (_jvm_invokevirtual "java.lang.String" ["java.lang.String" "int"] x [pattern (_jvm_l2i from)])) -1 #;None idx (#;Some idx)) @@ -82,13 +82,13 @@ (def #export ( pattern x) (-> Text Text (Maybe Int)) - (case (_jvm_i2l (_jvm_invokevirtual java.lang.String [java.lang.String] + (case (_jvm_i2l (_jvm_invokevirtual "java.lang.String" ["java.lang.String"] x [pattern])) -1 #;None idx (#;Some idx)))] - [index-of index-of' indexOf] - [last-index-of last-index-of' lastIndexOf] + [index-of index-of' "indexOf"] + [last-index-of last-index-of' "lastIndexOf"] ) (def #export (starts-with? prefix x) @@ -113,27 +113,22 @@ ## [Structures] (defstruct #export Text/Eq (E;Eq Text) (def (E;= x y) - (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y]))) (defstruct #export Text/Ord (O;Ord Text) (def O;_eq Text/Eq) - (def (O;< x y) - (i< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) - (def (O;<= x y) - (i<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) - (def (O;> x y) - (i> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0)) - (def (O;>= x y) - (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] - x [y])) - 0))) + + (do-template [ ] + [(def ( x y) + ( (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "compareTo" ["java.lang.String"] + x [y])) + 0))] + + [O;< i<] + [O;<= i<=] + [O;> i>] + [O;>= i>=])) (defstruct #export Text/Show (S;Show Text) (def (S;show x) @@ -142,5 +137,5 @@ (defstruct #export Text/Monoid (m;Monoid Text) (def m;unit "") (def (m;++ x y) - (_jvm_invokevirtual java.lang.String concat [java.lang.String] + (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] x [y]))) diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux deleted file mode 100644 index 9bd0c838c..000000000 --- a/source/lux/host/java.lux +++ /dev/null @@ -1,310 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux (control (monoid #as m) - (functor #as F) - (monad #as M #refer (#only do))) - (data (list #as l #refer #all #open ("" List/Functor)) - (text #as text)) - (meta lux - macro - syntax))) - -## [Utils/Parsers] -(def finally^ - (Parser Syntax) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "finally"]) - expr id^ - _ end^] - (M;wrap expr)))) - -(def catch^ - (Parser (, Text Ident Syntax)) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "catch"]) - ex-class local-symbol^ - ex symbol^ - expr id^ - _ end^] - (M;wrap [ex-class ex expr])))) - -(def method-decl^ - (Parser (, (List Text) Text (List Text) Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ local-symbol^)) - output local-symbol^ - _ end^] - (M;wrap [modifiers name inputs output])))) - -(def field-decl^ - (Parser (, (List Text) Text Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - class local-symbol^ - _ end^] - (M;wrap [modifiers name class])))) - -(def arg-decl^ - (Parser (, Text Text)) - (form^ (do Parser/Monad - [arg-name local-symbol^ - arg-class local-symbol^ - _ end^] - (M;wrap [arg-name arg-class])))) - -(def method-def^ - (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ arg-decl^)) - output local-symbol^ - body id^ - _ end^] - (M;wrap [modifiers name inputs output body])))) - -(def method-call^ - (Parser (, Text (List Text) (List Syntax))) - (form^ (do Parser/Monad - [method local-symbol^ - arity-classes (tuple^ (*^ local-symbol^)) - arity-args (tuple^ (*^ id^)) - _ end^ - _ (: (Parser (,)) - (if (i= (size arity-classes) - (size arity-args)) - (M;wrap []) - (lambda [_] #;None)))] - (M;wrap [method arity-classes arity-args]) - ))) - -## [Utils/Lux] -## (def (find-class-field field class) -## (-> Text Text (Lux Type)) -## ...) - -## (def (find-virtual-method method class) -## (-> Text Text (Lux (List (, (List Type) Type)))) -## ...) - -## (def (find-static-method method class) -## (-> Text Text (Lux (List (, (List Type) Type)))) -## ...) - - -## [Syntax] -(defsyntax #export (throw ex) - (emit (list (` (_jvm_throw (~ ex)))))) - -(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) - (emit (list (` (_jvm_try (~ body) - (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident Syntax) Syntax) - (lambda [catch] - (let [[class ex body] catch] - (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches) - (case finally - #;None - (list) - - (#;Some finally) - (list (` (_jvm_finally (~ finally))))))))))))) - -(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (do Lux/Monad - [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name))]] - (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) - members)] - (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (map text$ supers))] - (~@ members')))))))) - -(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] - [fields (*^ field-decl^)] - [methods (*^ method-def^)]) - (do Lux/Monad - [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name)) - fields' (map (: (-> (, (List Text) Text Text) Syntax) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (symbol$ ["" name])) - (~ (text$ class)) - [(~@ (map text$ modifiers))]))))) - fields) - methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (symbol$ ["" name])) - [(~@ (map (: (-> (, Text Text) Syntax) - (lambda [in] - (let [[left right] in] - (form$ (list (text$ left) - (text$ right)))))) - inputs))] - (~ (text$ output)) - [(~@ (map text$ modifiers))] - (~ body)))))) - methods)]] - (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ fields')] - [(~@ methods')])))))) - -(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) - (emit (list (` (_jvm_new (~ (text$ class)) - [(~@ (map text$ arg-classes))] - [(~@ args)]))))) - -(defsyntax #export (instance? [class local-symbol^] obj) - (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) - -(defsyntax #export (locking lock body) - (do Lux/Monad - [g!lock (gensym "") - g!body (gensym "")] - (emit (list (` (;let [(~ g!lock) (~ lock) - _ (_jvm_monitor-enter (~ g!lock)) - (~ g!body) (~ body) - _ (_jvm_monitor-exit (~ g!lock))] - (~ g!body))))) - )) - -(defsyntax #export (null? obj) - (emit (list (` (_jvm_null? (~ obj)))))) - -(defsyntax #export (program [args symbol^] body) - (emit (list (` (_jvm_program (~ (symbol$ args)) - (~ body)))))) - -## (defsyntax #export (.? [field local-symbol^] obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [field-class (find-field field class)] -## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)))) - -## _ -## (fail "Can only get field from object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.? (~ field) (~ g!obj))))))))) - -## (defsyntax #export (.= [field local-symbol^] value obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [field-class (find-field field class)] -## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value))) - -## _ -## (fail "Can only set field of object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.= (~ field) (~ value) (~ g!obj))))))))) - -## (defsyntax #export (.! [call method-call^] obj) -## (case obj -## (#;Meta [_ (#;SymbolS obj-name)]) -## (do Lux/Monad -## [obj-type (find-var-type obj-name)] -## (case obj-type -## (#;DataT class) -## (do Lux/Monad -## [#let [[m-name ?m-classes m-args] call] -## all-m-details (find-virtual-method m-name class) -## m-ins (case [?m-classes all-m-details] -## (\ [#;None (list [m-ins m-out])]) -## (M;wrap m-ins) - -## (\ [(#;Some m-ins) _]) -## (M;wrap m-ins) - -## _ -## #;None)] -## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))] -## (~ obj) [(~@ m-args)]))))) - -## _ -## (fail "Can only call method on object."))) - -## _ -## (do Lux/Monad -## [g!obj (gensym "")] -## (emit (list (` (;let [(~ g!obj) (~ obj)] -## (.! (~@ *tokens*))))))))) - -## (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) -## (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) - -## (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) -## (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) - -## (defsyntax #export (..! [call method-call^] [class local-symbol^]) -## (do Lux/Monad -## [#let [[m-name ?m-classes m-args] call] -## all-m-details (find-static-method m-name class) -## m-ins (case [?m-classes all-m-details] -## (\ [#;None (list [m-ins m-out])]) -## (M;wrap m-ins) - -## (\ [(#;Some m-ins) _]) -## (M;wrap m-ins) - -## _ -## #;None)] -## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class)) -## [(~@ (:: List/Functor (F;map text$ m-ins)))] -## [(~@ m-args)])))) -## )) - -## (definterface Function [] -## (#public #abstract apply [java.lang.Object] java.lang.Object)) - -## (_jvm_interface "Function" [] -## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) - -## (defclass MyFunction [Function] -## (#public #static foo java.lang.Object) -## (#public [] void -## (_jvm_invokespecial java.lang.Object [] this [])) -## (#public apply [(arg java.lang.Object)] java.lang.Object -## "YOLO")) - -## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] -## [(foo "java.lang.Object" ["public" "static"])] -## ( [] "void" -## ["public"] -## (_jvm_invokespecial java.lang.Object [] this [])) -## (apply [(arg "java.lang.Object")] "java.lang.Object" -## ["public"] -## "YOLO")) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux new file mode 100644 index 000000000..a3a74d608 --- /dev/null +++ b/source/lux/host/jvm.lux @@ -0,0 +1,270 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (control (monoid #as m) + (functor #as F) + (monad #as M #refer (#only do))) + (data (list #as l #refer #all #open ("" List/Functor)) + (text #as text)) + (meta lux + macro + syntax))) + +## [Utils] +## Parsers +(def finally^ + (Parser Syntax) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "finally"]) + expr id^ + _ end^] + (M;wrap expr)))) + +(def catch^ + (Parser (, Text Ident Syntax)) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "catch"]) + ex-class local-symbol^ + ex symbol^ + expr id^ + _ end^] + (M;wrap [ex-class ex expr])))) + +(def method-decl^ + (Parser (, (List Text) Text (List Text) Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ local-symbol^)) + output local-symbol^ + _ end^] + (M;wrap [modifiers name inputs output])))) + +(def field-decl^ + (Parser (, (List Text) Text Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + class local-symbol^ + _ end^] + (M;wrap [modifiers name class])))) + +(def arg-decl^ + (Parser (, Text Text)) + (form^ (do Parser/Monad + [arg-name local-symbol^ + arg-class local-symbol^ + _ end^] + (M;wrap [arg-name arg-class])))) + +(def method-def^ + (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ arg-decl^)) + output local-symbol^ + body id^ + _ end^] + (M;wrap [modifiers name inputs output body])))) + +(def method-call^ + (Parser (, Text (List Text) (List Syntax))) + (form^ (do Parser/Monad + [method local-symbol^ + arity-classes (tuple^ (*^ local-symbol^)) + arity-args (tuple^ (*^ id^)) + _ end^ + _ (: (Parser (,)) + (if (i= (size arity-classes) + (size arity-args)) + (M;wrap []) + (lambda [_] #;None)))] + (M;wrap [method arity-classes arity-args]) + ))) + +## [Syntax] +(defsyntax #export (throw ex) + (emit (list (` (_jvm_throw (~ ex)))))) + +(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) + (emit (list (` (_jvm_try (~ body) + (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident Syntax) Syntax) + (lambda [catch] + (let [[class ex body] catch] + (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches) + (case finally + #;None + (list) + + (#;Some finally) + (list (` (_jvm_finally (~ finally))))))))))))) + +(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name))]] + (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) + members)] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (map text$ supers))] + (~@ members')))))))) + +(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [fields (*^ field-decl^)] + [methods (*^ method-def^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name)) + fields' (map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" name])) + (~ (text$ class)) + [(~@ (map text$ modifiers))]))))) + fields) + methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (symbol$ ["" name])) + [(~@ (map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs))] + (~ (text$ output)) + [(~@ (map text$ modifiers))] + (~ body)))))) + methods)]] + (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ fields')] + [(~@ methods')])))))) + +(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) + (emit (list (` (_jvm_new (~ (text$ class)) + [(~@ (map text$ arg-classes))] + [(~@ args)]))))) + +(defsyntax #export (instance? [class local-symbol^] obj) + (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) + +(defsyntax #export (locking lock body) + (do Lux/Monad + [g!lock (gensym "") + g!body (gensym "")] + (emit (list (` (;let [(~ g!lock) (~ lock) + _ (_jvm_monitor-enter (~ g!lock)) + (~ g!body) (~ body) + _ (_jvm_monitor-exit (~ g!lock))] + (~ g!body))))) + )) + +(defsyntax #export (null? obj) + (emit (list (` (_jvm_null? (~ obj)))))) + +(defsyntax #export (program [args symbol^] body) + (emit (list (` (_jvm_program (~ (symbol$ args)) + (~ body)))))) + +(defsyntax #export (.? [field local-symbol^] obj) + (case obj + (#;Meta [_ (#;SymbolS obj-name)]) + (do Lux/Monad + [obj-type (find-var-type obj-name)] + (case obj-type + (#;DataT class) + (emit (list (` (_jvm_getfield (~ (text$ class)) (~ (text$ field)))))) + + _ + (fail "Can only get field from object."))) + + _ + (do Lux/Monad + [g!obj (gensym "")] + (emit (list (` (;let [(~ g!obj) (~ obj)] + (.? (~ (text$ field)) (~ g!obj))))))))) + +(defsyntax #export (.= [field local-symbol^] value obj) + (case obj + (#;Meta [_ (#;SymbolS obj-name)]) + (do Lux/Monad + [obj-type (find-var-type obj-name)] + (case obj-type + (#;DataT class) + (emit (list (` (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value))))) + + _ + (fail "Can only set field of object."))) + + _ + (do Lux/Monad + [g!obj (gensym "")] + (emit (list (` (;let [(~ g!obj) (~ obj)] + (.= (~ (text$ field)) (~ value) (~ g!obj))))))))) + +(defsyntax #export (.! [call method-call^] obj) + (case obj + (#;Meta [_ (#;SymbolS obj-name)]) + (do Lux/Monad + [obj-type (find-var-type obj-name)] + (case obj-type + (#;DataT class) + (let [[m-name ?m-classes m-args] call] + (emit (list (` (_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] + (~ obj) [(~@ m-args)]))))) + + _ + (fail "Can only call method on object."))) + + _ + (do Lux/Monad + [g!obj (gensym "")] + (emit (list (` (;let [(~ g!obj) (~ obj)] + (.! (~@ *tokens*))))))))) + +(defsyntax #export (..? [field local-symbol^] [class local-symbol^]) + (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) + +(defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) + (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) + +(defsyntax #export (..! [call method-call^] [class local-symbol^]) + (let [[m-name m-classes m-args] call] + (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) + [(~@ (map text$ m-classes))] + [(~@ m-args)])))))) + +## (definterface Function [] +## (#public #abstract apply [java.lang.Object] java.lang.Object)) + +## (_jvm_interface "Function" [] +## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (defclass MyFunction [Function] +## (#public #static foo java.lang.Object) +## (#public [] void +## (_jvm_invokespecial java.lang.Object [] this [])) +## (#public apply [(arg java.lang.Object)] java.lang.Object +## "YOLO")) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## ( [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) diff --git a/source/lux/math.lux b/source/lux/math.lux index 2e29c5da7..8a9432261 100644 --- a/source/lux/math.lux +++ b/source/lux/math.lux @@ -12,49 +12,49 @@ (do-template [ ] [(def #export Real - (_jvm_getstatic java.lang.Math ))] + (_jvm_getstatic "java.lang.Math" ))] - [e E] - [pi PI] + [e "E"] + [pi "PI"] ) ## [Functions] (do-template [ ] [(def #export ( n) (-> Real Real) - (_jvm_invokestatic java.lang.Math [double] [n]))] + (_jvm_invokestatic "java.lang.Math" ["double"] [n]))] - [cos cos] - [sin sin] - [tan tan] + [cos "cos"] + [sin "sin"] + [tan "tan"] - [acos acos] - [asin asin] - [atan atan] + [acos "acos"] + [asin "asin"] + [atan "atan"] - [cosh cosh] - [sinh sinh] - [tanh tanh] + [cosh "cosh"] + [sinh "sinh"] + [tanh "tanh"] - [ceil ceil] - [floor floor] - [round round] + [ceil "ceil"] + [floor "floor"] + [round "round"] - [exp exp] - [log log] + [exp "exp"] + [log "log"] - [cbrt cbrt] - [sqrt sqrt] + [cbrt "cbrt"] + [sqrt "sqrt"] - [->degrees toDegrees] - [->radians toRadians] + [->degrees "toDegrees"] + [->radians "toRadians"] ) (do-template [ ] [(def #export ( x y) (-> Real Real Real) - (_jvm_invokestatic java.lang.Math [double double] [x y]))] + (_jvm_invokestatic "java.lang.Math" ["double" "double"] [x y]))] - [atan2 atan2] - [pow pow] + [atan2 "atan2"] + [pow "pow"] ) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 83702f75d..fcee80b8f 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -235,7 +235,7 @@ _ (l;fail "Syntax pattern expects 2-tuples or symbols.")))) args) - g!tokens (gensym "tokens") + #let [g!tokens (m;symbol$ ["" "*tokens*"])] g!_ (gensym "_") #let [names (:: List/Functor (F;map first names+parsers)) error-msg (text$ (text:++ "Wrong syntax for " name)) diff --git a/source/program.lux b/source/program.lux index 18a2a76ab..37391eda9 100644 --- a/source/program.lux +++ b/source/program.lux @@ -32,7 +32,7 @@ state (text #as t #open ("text:" Text/Monoid)) writer) - (host java) + (host jvm) (meta lux macro syntax) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index f85b3d619..1606a95c2 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -166,57 +166,57 @@ (&&host/analyse-jvm-null? analyse ?object) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_instanceof"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] ["lux;Cons" [?object ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-instanceof analyse ?class ?object) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-new analyse ?class ?classes ?args) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-getstatic analyse ?class ?field) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] ["lux;Cons" [?object ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-getfield analyse ?class ?field ?object) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]] (&&host/analyse-jvm-putstatic analyse ?class ?field ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?field]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] ["lux;Cons" [?object ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-putfield analyse ?class ?field ?object ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokestatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]] (&&host/analyse-jvm-invokestatic analyse ?class ?method ?classes ?args) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokevirtual"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] ["lux;Cons" [?object ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] @@ -224,8 +224,8 @@ (&&host/analyse-jvm-invokevirtual analyse ?class ?method ?classes ?object ?args) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokeinterface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] ["lux;Cons" [?object ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] @@ -233,8 +233,8 @@ (&&host/analyse-jvm-invokeinterface analyse ?class ?method ?classes ?object ?args) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokespecial"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?method]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] ["lux;Cons" [?object ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] @@ -408,7 +408,7 @@ ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] (&&lux/analyse-def analyse ?name ?value) - + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] ["lux;Nil" _]]]]]]] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index cb76d8d54..ebbb6911a 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -101,8 +101,8 @@ (fail "##9##")))] (adjust-type* up type*)) - [_] - (assert false (aget type 0)) + ;; [_] + ;; (assert false (aget type 0)) )) (defn adjust-type [type] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index e490bc62f..11d43ce9e 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -18,14 +18,6 @@ [env :as &&env]))) ;; [Utils] -(defn ^:private extract-ident [ident] - (matchv ::M/objects [ident] - [["lux;Meta" [_ ["lux;SymbolS" [_ ?ident]]]]] - (return ?ident) - - [_] - (fail "[Analyser Error] Can't extract Symbol."))) - (defn ^:private extract-text [text] (matchv ::M/objects [text] [["lux;Meta" [_ ["lux;TextS" ?text]]]] @@ -115,7 +107,7 @@ (return (&/|list (&/T (&/V "jvm-putfield" (&/T ?class ?field =object =value)) =type))))) (defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args] - (|do [=classes (&/map% &host/extract-jvm-param ?classes) + (|do [=classes (&/map% extract-text ?classes) =return (&host/lookup-static-method ?class ?method =classes) ;; :let [_ (matchv ::M/objects [=return] ;; [["lux;DataT" _return-class]] @@ -138,7 +130,7 @@ (do-template [ ] (defn [analyse ?class ?method ?classes ?object ?args] - (|do [=classes (&/map% &host/extract-jvm-param ?classes) + (|do [=classes (&/map% extract-text ?classes) =return (&host/lookup-virtual-method ?class ?method =classes) =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) =args (&/map2% (fn [?c ?o] @@ -151,7 +143,7 @@ ) (defn analyse-jvm-invokespecial [analyse ?class ?method ?classes ?object ?args] - (|do [=classes (&/map% &host/extract-jvm-param ?classes) + (|do [=classes (&/map% extract-text ?classes) =return (if (= "" ?method) (return &type/$Void) (&host/lookup-virtual-method ?class ?method =classes)) @@ -166,7 +158,7 @@ (return (&/|list (&/T (&/V "jvm-null?" =object) (&/V "lux;DataT" "java.lang.Boolean")))))) (defn analyse-jvm-new [analyse ?class ?classes ?args] - (|do [=classes (&/map% &host/extract-jvm-param ?classes) + (|do [=classes (&/map% extract-text ?classes) =args (&/flat-map% analyse ?args)] (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) (&/V "lux;DataT" ?class)))))) @@ -239,7 +231,7 @@ (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (matchv ::M/objects [?field] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?field-name]]]] + [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-name]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-type]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?field-modifiers]]] ["lux;Nil" _]]]]]]]]]]] @@ -253,7 +245,7 @@ ?fields) =methods (&/map% (fn [?method] (matchv ::M/objects [?method] - [[?idx ["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?method-name]]]] + [[?idx ["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-inputs]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-output]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-modifiers]]] @@ -297,7 +289,7 @@ (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (matchv ::M/objects [method] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?method-name]]]] + [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?inputs]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?output]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?modifiers]]] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index f1c261d6b..b1023689e 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -64,10 +64,7 @@ (|do [:let [_ (doto *writer* (.visitInsn Opcodes/DUP) (.visitLdcInsn (int idx)))] - ret (try (compile elem) - (catch Exception e - (prn 'compile-tuple (aget elem 0) (->> ?elems (&/|map #(aget % 0)) &/->seq)) - (throw e))) + ret (compile elem) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return ret))) (&/|range num-elems) ?elems)] diff --git a/src/lux/host.clj b/src/lux/host.clj index d248c708e..cf9830169 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -75,14 +75,6 @@ "V" )) -(defn extract-jvm-param [token] - (matchv ::M/objects [token] - [["lux;Meta" [_ ["lux;SymbolS" [_ ?ident]]]]] - (return ?ident) - - [_] - (fail (str "[Host] Unknown JVM param: " (pr-str token))))) - (do-template [ ] (defn [target field] (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName target)) -- cgit v1.2.3 From c79621772c862e9b94e1fc43e11996cbac54fed1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 29 Jul 2015 20:20:26 -0400 Subject: - lux;using no longer prefixes variables. - Fixed several bugs with host (JVM) interop. - Now packaging everything in a .jar file ("program.jar"). --- source/lux.lux | 4 +- source/lux/control/comonad.lux | 4 +- source/lux/control/monad.lux | 2 +- source/lux/data/list.lux | 2 +- source/lux/data/number.lux | 4 +- source/lux/data/text.lux | 4 +- source/lux/host/jvm.lux | 108 +++++++------------- source/lux/math.lux | 5 +- source/lux/meta/lux.lux | 16 +-- source/lux/meta/syntax.lux | 4 +- source/program.lux | 10 +- src/lux.clj | 12 ++- src/lux/analyser.clj | 169 ++++++++++++++++--------------- src/lux/analyser/host.clj | 222 ++++++++++++++++++++++++++--------------- src/lux/analyser/lux.clj | 4 +- src/lux/base.clj | 5 +- src/lux/compiler.clj | 27 +++-- src/lux/compiler/base.clj | 32 +++++- src/lux/compiler/cache.clj | 7 +- src/lux/compiler/host.clj | 206 ++++++++++++++++++++++---------------- src/lux/compiler/package.clj | 61 +++++++++++ src/lux/host.clj | 16 +-- src/lux/type.clj | 150 +++++++++++----------------- 23 files changed, 611 insertions(+), 463 deletions(-) create mode 100644 src/lux/compiler/package.clj diff --git a/source/lux.lux b/source/lux.lux index c51929635..8861bc241 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -2524,8 +2524,8 @@ (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) (lambda [slot] (let [[sname stype] slot - full-name (split-slot sname)] - [(tag$ full-name) (symbol$ full-name)]))) + [module name] (split-slot sname)] + [(tag$ [module name]) (symbol$ ["" name])]))) slots))] (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux index 1830ff44f..ce9a7e7de 100644 --- a/source/lux/control/comonad.lux +++ b/source/lux/control/comonad.lux @@ -27,8 +27,8 @@ (All [w a b] (-> (CoMonad w) (-> (w a) b) (w a) (w b))) (using w - (using ;;_functor - (F;map f (;;split ma))))) + (using _functor + (map f (split ma))))) ## Syntax (defmacro #export (be tokens state) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index b5552f987..a03c1499a 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -82,7 +82,7 @@ (All [m a b] (-> (Monad m) (-> a (m b)) (m a) (m b))) (using m - (;;join (:: ;;_functor (F;map f ma))))) + (join (:: _functor (F;map f ma))))) (def #export (map% m f xs) (All [m a b] diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 450dee275..8fd5c2951 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -247,4 +247,4 @@ (def (M;join mma) (using List/Monoid - (foldL m;++ m;unit mma)))) + (foldL ++ unit mma)))) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux index 453c30a13..8771ef06e 100644 --- a/source/lux/data/number.lux +++ b/source/lux/data/number.lux @@ -68,11 +68,11 @@ (def O;< ) (def (O;<= x y) (or ( x y) - (using (E;= x y)))) + (:: (E;= x y)))) (def O;> ) (def (O;>= x y) (or ( x y) - (using (E;= x y)))))] + (:: (E;= x y)))))] [ Int/Ord Int Int/Eq i< i>] [Real/Ord Real Real/Eq r< r>]) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index f7f1a86c0..6ad9cfd63 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -46,8 +46,8 @@ (if (and (i< from to) (i>= from 0) (i<= to (size x))) - (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] - x [(_jvm_l2i from) (_jvm_l2i to)]) + (#;Some (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] + x [(_jvm_l2i from) (_jvm_l2i to)])) #;None)) (def #export (sub from x) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index a3a74d608..7af043969 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -22,8 +22,7 @@ (Parser Syntax) (form^ (do Parser/Monad [_ (symbol?^ ["" "finally"]) - expr id^ - _ end^] + expr id^] (M;wrap expr)))) (def catch^ @@ -32,8 +31,7 @@ [_ (symbol?^ ["" "catch"]) ex-class local-symbol^ ex symbol^ - expr id^ - _ end^] + expr id^] (M;wrap [ex-class ex expr])))) (def method-decl^ @@ -42,8 +40,7 @@ [modifiers (*^ local-tag^) name local-symbol^ inputs (tuple^ (*^ local-symbol^)) - output local-symbol^ - _ end^] + output local-symbol^] (M;wrap [modifiers name inputs output])))) (def field-decl^ @@ -51,16 +48,14 @@ (form^ (do Parser/Monad [modifiers (*^ local-tag^) name local-symbol^ - class local-symbol^ - _ end^] + class local-symbol^] (M;wrap [modifiers name class])))) (def arg-decl^ (Parser (, Text Text)) (form^ (do Parser/Monad [arg-name local-symbol^ - arg-class local-symbol^ - _ end^] + arg-class local-symbol^] (M;wrap [arg-name arg-class])))) (def method-def^ @@ -70,8 +65,7 @@ name local-symbol^ inputs (tuple^ (*^ arg-decl^)) output local-symbol^ - body id^ - _ end^] + body id^] (M;wrap [modifiers name inputs output body])))) (def method-call^ @@ -80,7 +74,6 @@ [method local-symbol^ arity-classes (tuple^ (*^ local-symbol^)) arity-args (tuple^ (*^ id^)) - _ end^ _ (: (Parser (,)) (if (i= (size arity-classes) (size arity-args)) @@ -108,47 +101,41 @@ (list (` (_jvm_finally (~ finally))))))))))))) (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (do Lux/Monad - [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name))]] - (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (symbol$ ["" name])) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) - members)] - (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (map text$ supers))] - (~@ members')))))))) + (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) + members)] + (emit (list (` (_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] + (~@ members'))))))) (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] [fields (*^ field-decl^)] [methods (*^ method-def^)]) (do Lux/Monad [current-module get-module-name - #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) - name)) - fields' (map (: (-> (, (List Text) Text Text) Syntax) + #let [fields' (map (: (-> (, (List Text) Text Text) Syntax) (lambda [field] (let [[modifiers name class] field] - (` ((~ (symbol$ ["" name])) + (` ((~ (text$ name)) (~ (text$ class)) [(~@ (map text$ modifiers))]))))) fields) methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) (lambda [methods] (let [[modifiers name inputs output body] methods] - (` ((~ (symbol$ ["" name])) + (` ((~ (text$ name)) [(~@ (map (: (-> (, Text Text) Syntax) (lambda [in] (let [[left right] in] - (form$ (list (text$ left) + (form$ (list (symbol$ ["" left]) (text$ right)))))) inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))] (~ body)))))) methods)]] - (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) + (emit (list (` (_jvm_class (~ (text$ name)) (~ (text$ super)) [(~@ (map text$ interfaces))] [(~@ fields')] [(~@ methods')])))))) @@ -166,9 +153,9 @@ [g!lock (gensym "") g!body (gensym "")] (emit (list (` (;let [(~ g!lock) (~ lock) - _ (_jvm_monitor-enter (~ g!lock)) + _ (_jvm_monitorenter (~ g!lock)) (~ g!body) (~ body) - _ (_jvm_monitor-exit (~ g!lock))] + _ (_jvm_monitorexit (~ g!lock))] (~ g!body))))) )) @@ -216,24 +203,27 @@ (.= (~ (text$ field)) (~ value) (~ g!obj))))))))) (defsyntax #export (.! [call method-call^] obj) - (case obj - (#;Meta [_ (#;SymbolS obj-name)]) - (do Lux/Monad - [obj-type (find-var-type obj-name)] - (case obj-type - (#;DataT class) - (let [[m-name ?m-classes m-args] call] + (let [[m-name ?m-classes m-args] call] + (case obj + (#;Meta [_ (#;SymbolS obj-name)]) + (do Lux/Monad + [obj-type (find-var-type obj-name)] + (case obj-type + (#;DataT class) (emit (list (` (_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] - (~ obj) [(~@ m-args)]))))) + (~ obj) [(~@ m-args)])))) - _ - (fail "Can only call method on object."))) + _ + (fail "Can only call method on object."))) - _ - (do Lux/Monad - [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.! (~@ *tokens*))))))))) + _ + (do Lux/Monad + [g!obj (gensym "")] + (emit (list (` (;let [(~ g!obj) (~ obj)] + (.! ((~ (symbol$ ["" m-name])) + [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))] + [(~@ m-args)]) + (~ g!obj)))))))))) (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) @@ -246,25 +236,3 @@ (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ m-classes))] [(~@ m-args)])))))) - -## (definterface Function [] -## (#public #abstract apply [java.lang.Object] java.lang.Object)) - -## (_jvm_interface "Function" [] -## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) - -## (defclass MyFunction [Function] -## (#public #static foo java.lang.Object) -## (#public [] void -## (_jvm_invokespecial java.lang.Object [] this [])) -## (#public apply [(arg java.lang.Object)] java.lang.Object -## "YOLO")) - -## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] -## [(foo "java.lang.Object" ["public" "static"])] -## ( [] "void" -## ["public"] -## (_jvm_invokespecial java.lang.Object [] this [])) -## (apply [(arg "java.lang.Object")] "java.lang.Object" -## ["public"] -## "YOLO")) diff --git a/source/lux/math.lux b/source/lux/math.lux index 8a9432261..a495d130c 100644 --- a/source/lux/math.lux +++ b/source/lux/math.lux @@ -38,7 +38,6 @@ [ceil "ceil"] [floor "floor"] - [round "round"] [exp "exp"] [log "log"] @@ -50,6 +49,10 @@ [->radians "toRadians"] ) +(def #export (round n) + (-> Real Int) + (_jvm_invokestatic "java.lang.Math" "round" ["double"] [n])) + (do-template [ ] [(def #export ( x y) (-> Real Real Real) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 99ca200cf..19b7dd9df 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -187,14 +187,14 @@ (case (get module (get@ #;modules state)) (#;Some =module) (using List/Monad - (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (list name) - (list))))) - (get@ #;defs =module))))])) + (#;Right [state (join (:: _functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) + (List Text)) + (lambda [gdef] + (let [[name [export? _]] gdef] + (if export? + (list name) + (list))))) + (get@ #;defs =module))))])) #;None (#;Left ($ text:++ "Unknown module: " module)))) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index fcee80b8f..63ab81475 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -235,7 +235,7 @@ _ (l;fail "Syntax pattern expects 2-tuples or symbols.")))) args) - #let [g!tokens (m;symbol$ ["" "*tokens*"])] + g!tokens (gensym "tokens") g!_ (gensym "_") #let [names (:: List/Functor (F;map first names+parsers)) error-msg (text$ (text:++ "Wrong syntax for " name)) @@ -249,7 +249,7 @@ (~ g!_) (l;fail (~ error-msg))))))) body - (reverse names+parsers)) + (: (List (, Syntax Syntax)) (list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) macro-def (: Syntax (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) (~ body'))))]] diff --git a/source/program.lux b/source/program.lux index 37391eda9..086506725 100644 --- a/source/program.lux +++ b/source/program.lux @@ -41,8 +41,8 @@ (program args (case args - #;Nil - (println "Hello, world!") - - (#;Cons [name _]) - (println ($ text:++ "Hello, " name "!")))) + (\ (list name)) + (println ($ text:++ "Hello, " name "!")) + + _ + (println "Hello, world!"))) diff --git a/src/lux.clj b/src/lux.clj index 9c913c9ac..7e3627cd7 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -10,13 +10,15 @@ (:gen-class) (:require [lux.base :as &] [lux.compiler :as &compiler] - [lux.type :as &type] :reload-all)) -(defn -main [& _] - (time (&compiler/compile-all (&/|list "lux" "program"))) - (System/exit 0)) +(defn -main [& [program-module & _]] + (if program-module + (time (&compiler/compile-program program-module)) + (println "Please provide a module name to compile.")) + (System/exit 0) + ) (comment - ;; cd output && jar cvf program.jar * && java -cp "program.jar" program && cd .. + (-main "program") ) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 1606a95c2..de7fc8497 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail* |list]] + (lux [base :as & :refer [|let |do return fail return* fail*]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -23,16 +23,16 @@ (defn ^:private parse-handler [[catch+ finally+] token] (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_catch"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?ex-class]]] ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-arg]]]] ["lux;Cons" [?catch-body ["lux;Nil" _]]]]]]]]]]]]] - (&/T (&/|++ catch+ (|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+) + (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_finally"]]]] ["lux;Cons" [?finally-body ["lux;Nil" _]]]]]]]]] - (&/T catch+ ?finally-body))) + (&/T catch+ (&/V "lux;Some" ?finally-body)))) (defn ^:private aba7 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] @@ -62,7 +62,8 @@ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] - ?methods]]]]]]]]]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?methods]]] + ["lux;Nil" _]]]]]]]]]]]]]]] (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] @@ -85,74 +86,74 @@ (matchv ::M/objects [token] ;; Primitive conversions [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-d2f analyse ?value) + (&&host/analyse-jvm-d2f analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-d2i analyse ?value) + (&&host/analyse-jvm-d2i analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-d2l analyse ?value) + (&&host/analyse-jvm-d2l analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-f2d analyse ?value) + (&&host/analyse-jvm-f2d analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-f2i analyse ?value) + (&&host/analyse-jvm-f2i analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-f2l analyse ?value) + (&&host/analyse-jvm-f2l analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2b analyse ?value) + (&&host/analyse-jvm-i2b analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2c analyse ?value) + (&&host/analyse-jvm-i2c analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2d analyse ?value) + (&&host/analyse-jvm-i2d analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2f analyse ?value) + (&&host/analyse-jvm-i2f analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2l analyse ?value) + (&&host/analyse-jvm-i2l analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2s analyse ?value) + (&&host/analyse-jvm-i2s analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-l2d analyse ?value) + (&&host/analyse-jvm-l2d analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-l2f analyse ?value) + (&&host/analyse-jvm-l2f analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-l2i analyse ?value) + (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-iand analyse ?x ?y) + (&&host/analyse-jvm-iand analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ior analyse ?x ?y) + (&&host/analyse-jvm-ior analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-land analyse ?x ?y) + (&&host/analyse-jvm-land analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lor analyse ?x ?y) + (&&host/analyse-jvm-lor analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lxor analyse ?x ?y) + (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lshl analyse ?x ?y) + (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lshr analyse ?x ?y) + (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lushr analyse ?x ?y) + (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) [_] (aba7 analyse eval! compile-module exo-type token))) @@ -163,40 +164,40 @@ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] ["lux;Cons" [?object ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-null? analyse ?object) + (&&host/analyse-jvm-null? analyse exo-type ?object) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_instanceof"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] ["lux;Cons" [?object ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-instanceof analyse ?class ?object) + (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-new analyse ?class ?classes ?args) + (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getstatic"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-getstatic analyse ?class ?field) + (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getfield"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] ["lux;Cons" [?object ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-getfield analyse ?class ?field ?object) + (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putstatic"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]] - (&&host/analyse-jvm-putstatic analyse ?class ?field ?value) + (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putfield"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] @@ -204,7 +205,7 @@ ["lux;Cons" [?object ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]]]] - (&&host/analyse-jvm-putfield analyse ?class ?field ?object ?value) + (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokestatic"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] @@ -212,7 +213,7 @@ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]] - (&&host/analyse-jvm-invokestatic analyse ?class ?method ?classes ?args) + (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokevirtual"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] @@ -221,7 +222,7 @@ ["lux;Cons" [?object ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokevirtual analyse ?class ?method ?classes ?object ?args) + (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokeinterface"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] @@ -230,7 +231,7 @@ ["lux;Cons" [?object ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokeinterface analyse ?class ?method ?classes ?object ?args) + (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokespecial"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] @@ -239,29 +240,29 @@ ["lux;Cons" [?object ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokespecial analyse ?class ?method ?classes ?object ?args) - + (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) + ;; Exceptions [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]] ["lux;Cons" [?body ?handlers]]]]]] - (&&host/analyse-jvm-try analyse ?body (&/fold parse-handler [(list) nil] ?handlers)) + (&&host/analyse-jvm-try analyse exo-type ?body (&/fold parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] ["lux;Cons" [?ex ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-throw analyse ?ex) + (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorenter"]]]] ["lux;Cons" [?monitor ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-monitorenter analyse ?monitor) + (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorexit"]]]] ["lux;Cons" [?monitor ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-monitorexit analyse ?monitor) + (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) [_] (aba6 analyse eval! compile-module exo-type token))) @@ -270,53 +271,53 @@ (matchv ::M/objects [token] ;; Float arithmetic [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fadd analyse ?x ?y) + (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fsub analyse ?x ?y) + (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fmul analyse ?x ?y) + (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fdiv analyse ?x ?y) + (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-frem analyse ?x ?y) + (&&host/analyse-jvm-frem analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-feq analyse ?x ?y) + (&&host/analyse-jvm-feq analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-flt analyse ?x ?y) + (&&host/analyse-jvm-flt analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fgt analyse ?x ?y) + (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dadd analyse ?x ?y) + (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dsub analyse ?x ?y) + (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dmul analyse ?x ?y) + (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ddiv analyse ?x ?y) + (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-drem analyse ?x ?y) + (&&host/analyse-jvm-drem analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-deq analyse ?x ?y) + (&&host/analyse-jvm-deq analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dlt analyse ?x ?y) + (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-dgt analyse ?x ?y) + (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) [_] (aba5 analyse eval! compile-module exo-type token))) @@ -326,63 +327,63 @@ ;; Host special forms ;; Characters [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ceq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ceq analyse ?x ?y) + (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_clt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-clt analyse ?x ?y) + (&&host/analyse-jvm-clt analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_cgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-cgt analyse ?x ?y) + (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-iadd analyse ?x ?y) + (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-isub analyse ?x ?y) + (&&host/analyse-jvm-isub analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-imul analyse ?x ?y) + (&&host/analyse-jvm-imul analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-idiv analyse ?x ?y) + (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-irem analyse ?x ?y) + (&&host/analyse-jvm-irem analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ieq analyse ?x ?y) + (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ilt analyse ?x ?y) + (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-igt analyse ?x ?y) + (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ladd analyse ?x ?y) + (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lsub analyse ?x ?y) + (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lmul analyse ?x ?y) + (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ldiv analyse ?x ?y) + (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lrem analyse ?x ?y) + (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-leq analyse ?x ?y) + (&&host/analyse-jvm-leq analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-llt analyse ?x ?y) + (&&host/analyse-jvm-llt analyse exo-type ?x ?y) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-lgt analyse ?x ?y) + (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) [_] (aba4 analyse eval! compile-module exo-type token))) @@ -445,7 +446,7 @@ [_] (aba3 analyse eval! compile-module exo-type token))) -(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (|list))))] +(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))] (defn ^:private aba1 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] ;; Standard special forms @@ -479,7 +480,7 @@ (&&lux/analyse-variant analyse exo-type ?ident unit) [["lux;SymbolS" [_ "_jvm_null"]]] - (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) + (&&host/analyse-jvm-null analyse exo-type) [_] (aba2 analyse eval! compile-module exo-type token) @@ -505,7 +506,11 @@ [["lux;Left" msg]] (fail* (add-loc meta msg)) - )))) + )) + + ;; [_] + ;; (assert false (aget token 0)) + )) (defn ^:private just-analyse [analyse-ast eval! compile-module syntax] (&type/with-var diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 11d43ce9e..5033f4f2c 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -36,13 +36,32 @@ (return (&/T ?item =type))) ))))) +(defn ^:private ensure-object [token] + "(-> Analysis (Lux (,)))" + (matchv ::M/objects [token] + [[_ ["lux;DataT" _]]] + (return nil) + + [_] + (fail "[Analyser Error] Expecting object"))) + +(defn ^:private as-object [type] + "(-> Type Type)" + (matchv ::M/objects [type] + [["lux;DataT" class]] + (&/V "lux;DataT" (&type/as-obj class)) + + [_] + type)) + ;; [Resources] (do-template [ ] (let [input-type (&/V "lux;DataT" ) output-type (&/V "lux;DataT" )] - (defn [analyse ?x ?y] + (defn [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) - =y (&&/analyse-1 analyse input-type ?y)] + =y (&&/analyse-1 analyse input-type ?y) + _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V (&/T =x =y)) output-type)))))) analyse-jvm-iadd "jvm-iadd" "java.lang.Integer" "java.lang.Integer" @@ -86,94 +105,121 @@ analyse-jvm-dgt "jvm-dgt" "java.lang.Double" "java.lang.Boolean" ) -(defn analyse-jvm-getstatic [analyse ?class ?field] - (|do [=type (&host/lookup-static-field ?class ?field)] - (return (&/|list (&/T (&/V "jvm-getstatic" (&/T ?class ?field)) =type))))) - -(defn analyse-jvm-getfield [analyse ?class ?field ?object] - (|do [=type (&host/lookup-static-field ?class ?field) - =object (&&/analyse-1 analyse ?object)] - (return (&/|list (&/T (&/V "jvm-getfield" (&/T ?class ?field =object)) =type))))) - -(defn analyse-jvm-putstatic [analyse ?class ?field ?value] - (|do [=type (&host/lookup-static-field ?class ?field) - =value (&&/analyse-1 analyse =type ?value)] - (return (&/|list (&/T (&/V "jvm-putstatic" (&/T ?class ?field =value)) =type))))) +(defn analyse-jvm-getstatic [analyse exo-type ?class ?field] + (|do [class-loader &/loader + =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))))) -(defn analyse-jvm-putfield [analyse ?class ?field ?object ?value] - (|do [=type (&host/lookup-static-field ?class ?field) +(defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] + (|do [class-loader &/loader + =type (&host/lookup-static-field class-loader ?class ?field) =object (&&/analyse-1 analyse ?object) - =value (&&/analyse-1 analyse =type ?value)] - (return (&/|list (&/T (&/V "jvm-putfield" (&/T ?class ?field =object =value)) =type))))) - -(defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args] - (|do [=classes (&/map% extract-text ?classes) - =return (&host/lookup-static-method ?class ?method =classes) + :let [output-type =type] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-getfield" (&/T ?class ?field =object)) output-type))))) + +(defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] + (|do [class-loader &/loader + =type (&host/lookup-static-field class-loader ?class ?field) + =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))))) + +(defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] + (|do [class-loader &/loader + =type (&host/lookup-static-field class-loader ?class ?field) + =object (&&/analyse-1 analyse ?object) + =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))))) + +(defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] + (|do [class-loader &/loader + =classes (&/map% extract-text ?classes) + =return (&host/lookup-static-method class-loader ?class ?method =classes) ;; :let [_ (matchv ::M/objects [=return] ;; [["lux;DataT" _return-class]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] (&&/analyse-1 analyse (&/V "lux;DataT" _class) _arg)) =classes - ?args)] - (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T ?class ?method =classes =args)) =return))))) + ?args) + :let [output-type =return] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T ?class ?method =classes =args)) output-type))))) -(defn analyse-jvm-instanceof [analyse ?class ?object] +(defn analyse-jvm-instanceof [analyse exo-type ?class ?object] (|do [=object (analyse-1+ analyse ?object) - :let [[_obj _type] =object]] - (matchv ::M/objects [_type] - [["lux;DataT" _]] - (return (&/|list (&/T (&/V "jvm-instanceof" (&/T ?class ?object)) (&/V "lux;DataT" "java.lang.Boolean")))) - - [_] - (fail "[Analyser Error] Can only use instanceof with object types.")))) + _ (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))))) (do-template [ ] - (defn [analyse ?class ?method ?classes ?object ?args] - (|do [=classes (&/map% extract-text ?classes) - =return (&host/lookup-virtual-method ?class ?method =classes) + (defn [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 "lux;DataT" ?class) ?object) - =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) - =classes ?args)] - (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) =return))))) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) + =classes ?args) + :let [output-type =return] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) output-type))))) analyse-jvm-invokevirtual "jvm-invokevirtual" analyse-jvm-invokeinterface "jvm-invokeinterface" ) -(defn analyse-jvm-invokespecial [analyse ?class ?method ?classes ?object ?args] - (|do [=classes (&/map% extract-text ?classes) +(defn analyse-jvm-invokespecial [analyse exo-type ?class ?method ?classes ?object ?args] + (|do [class-loader &/loader + =classes (&/map% extract-text ?classes) =return (if (= "" ?method) - (return &type/$Void) - (&host/lookup-virtual-method ?class ?method =classes)) + (return &type/Unit) + (&host/lookup-virtual-method class-loader ?class ?method =classes)) =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) - =classes ?args)] - (return (&/|list (&/T (&/V "jvm-invokespecial" (&/T ?class ?method =classes =object =args)) =return))))) + =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))))) + +(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))))) -(defn analyse-jvm-null? [analyse ?object] - (|do [=object (&&/analyse-1 analyse ?object)] - (return (&/|list (&/T (&/V "jvm-null?" =object) (&/V "lux;DataT" "java.lang.Boolean")))))) +(defn analyse-jvm-null [analyse exo-type] + (|do [:let [output-type (&/V "lux;DataT" "null")] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-null" nil) output-type))))) -(defn analyse-jvm-new [analyse ?class ?classes ?args] +(defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) - =args (&/flat-map% analyse ?args)] - (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) (&/V "lux;DataT" ?class)))))) + =args (&/map% (partial analyse-1+ analyse) ?args) + :let [output-type (&/V "lux;DataT" ?class)] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-new" (&/T ?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 "lux;DataT" ?class) (&/V "lux;Nil" nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] - (|do [=array (&&/analyse-1 analyse &type/$Void ?array) - =elem (&&/analyse-1 analyse &type/$Void ?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))))) (defn analyse-jvm-aaload [analyse ?array ?idx] - (|do [=array (&&/analyse-1 analyse ?array) + (|do [=array (analyse-1+ analyse ?array) =array-type (&&/expr-type =array)] (return (&/|list (&/T (&/V "jvm-aaload" (&/T =array ?idx)) =array-type))))) @@ -259,7 +305,7 @@ (return (&/T (&/ident->text ?input-name) ?input-type)) [_] - (fail "[Analyser Error] Wrong syntax for method."))) + (fail "[Analyser Error] Wrong syntax for method input."))) ?method-inputs) =method-modifiers (analyse-modifiers ?method-modifiers) =method-body (&/with-scope (str ?name "_" ?idx) @@ -302,37 +348,49 @@ :output ?output})) [_] - (fail "[Analyser Error] Invalid method signature!"))) + (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods)] (return (&/|list (&/V "jvm-interface" (&/T ?name =supers =methods)))))) -(defn analyse-jvm-try [analyse ?body [?catches ?finally]] - (|do [=body (&&/analyse-1 analyse ?body) +(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]] - (&&env/with-local ?ex-arg (&/V "lux;DataT" ?ex-class) - (|do [=catch-body (&&/analyse-1 analyse ?catch-body)] - (return [?ex-class ?ex-arg =catch-body])))) + (|do [=catch-body (&&env/with-local (str ";" ?ex-arg) (&/V "lux;DataT" ?ex-class) + (&&/analyse-1 analyse exo-type ?catch-body)) + idx &&env/next-local-idx] + (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (&&/analyse-1 analyse ?finally) - =body-type (&&/expr-type =body)] - (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) =body-type))))) - -(defn analyse-jvm-throw [analyse ?ex] - (|do [=ex (&&/analyse-1 analyse ?ex)] + =finally (matchv ::M/objects [?finally] + [["lux;None" _]] (return (&/V "lux;None" nil)) + [["lux;Some" ?finally*]] (|do [=finally (analyse-1+ analyse ?finally*)] + (return (&/V "lux;Some" =finally))))] + (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) exo-type))))) + +(defn analyse-jvm-throw [analyse exo-type ?ex] + (|do [=ex (analyse-1+ analyse ?ex) + :let [[_obj _type] =ex] + _ (&type/check (&/V "lux;DataT" "java.lang.Throwable") _type)] (return (&/|list (&/T (&/V "jvm-throw" =ex) &type/$Void))))) -(defn analyse-jvm-monitorenter [analyse ?monitor] - (|do [=monitor (&&/analyse-1 analyse ?monitor)] - (return (&/|list (&/T (&/V "jvm-monitorenter" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil))))))) - -(defn analyse-jvm-monitorexit [analyse ?monitor] - (|do [=monitor (&&/analyse-1 analyse ?monitor)] - (return (&/|list (&/T (&/V "jvm-monitorexit" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil))))))) +(do-template [ ] + (defn [analyse exo-type ?monitor] + (|do [=monitor (analyse-1+ analyse ?monitor) + _ (ensure-object =monitor) + :let [output-type &type/Unit] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V =monitor) output-type))))) + + analyse-jvm-monitorenter "jvm-monitorenter" + analyse-jvm-monitorexit "jvm-monitorexit" + ) (do-template [ ] - (defn [analyse ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" ) ?value)] - (return (&/|list (&/T (&/V =value) (&/V "lux;DataT" )))))) + (let [output-type (&/V "lux;DataT" )] + (defn [analyse exo-type ?value] + (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" ) ?value) + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V =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" @@ -355,9 +413,11 @@ ) (do-template [ ] - (defn [analyse ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" ) ?value)] - (return (&/|list (&/T (&/V =value) (&/V "lux;DataT" )))))) + (let [output-type (&/V "lux;DataT" )] + (defn [analyse exo-type ?value] + (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" ) ?value) + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V =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" diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 4a912f1c1..065e150d9 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -261,11 +261,11 @@ (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] ;; :let [_ (when (and ;; (= "lux/control/monad" ?module) - ;; (= "open" ?name)) + ;; (= "case" ?name)) ;; (->> (&/|map &/show-ast macro-expansion*) ;; (&/|interpose "\n") ;; (&/fold str "") - ;; (prn ?module "open")))] + ;; (prn ?module "case")))] ] (&/flat-map% (partial analyse exo-type) macro-expansion*)) diff --git a/src/lux/base.clj b/src/lux/base.clj index 9f0a78fa7..eb94c2c90 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -466,7 +466,10 @@ (findClass [^String class-name] ;; (prn 'findClass class-name) (if-let [^bytes bytecode (get @store class-name)] - (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) + (try (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) + (catch java.lang.reflect.InvocationTargetException e + (prn 'InvocationTargetException (.getCause e)) + (throw e))) (do (prn 'memory-class-loader/store class-name (keys @store)) (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index bb1c72f66..3449900e0 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -28,7 +28,8 @@ [lux :as &&lux] [host :as &&host] [case :as &&case] - [lambda :as &&lambda])) + [lambda :as &&lambda] + [package :as &&package])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -383,17 +384,18 @@ (fail "[Compiler Error] Can't redefine a module!") (|do [_ (&a-module/enter-module name) :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) .visitEnd) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) - .visitEnd))]] + .visitEnd)) + ;; _ (prn 'compile-module name =class) + ]] (fn [state] - (matchv ::M/objects [((&/exhaust% compiler-step) - (->> state - (&/set$ &/$SOURCE (&reader/from file-name file-content)) - (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %))))] + (matchv ::M/objects [((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$SOURCE (&reader/from file-name file-content) state))] [["lux;Right" [?state _]]] (&/run-state (|do [defs &a-module/defs imports &a-module/imports @@ -409,7 +411,9 @@ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil (->> imports (&/|interpose "\t") (&/fold str ""))) .visitEnd) - (.visitEnd))]] + (.visitEnd)) + ;; _ (prn 'CLOSED name =class) + ]] (&&/save-class! "_" (.toByteArray =class))) ?state) @@ -421,12 +425,13 @@ (.mkdirs (java.io.File. &&/output-dir))) ;; [Resources] -(defn compile-all [modules] +(defn compile-program [program-module] (init!) - (matchv ::M/objects [((&/map% compile-module modules) (&/init-state nil))] + (matchv ::M/objects [((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil))] [["lux;Right" [?state _]]] (do (println "Compilation complete!") - (&&cache/clean ?state)) + (&&cache/clean ?state) + (&&package/package program-module)) [["lux;Left" ?message]] (assert false ?message))) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 0631f51e8..28339c162 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -7,7 +7,8 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.compiler.base - (:require [clojure.string :as string] + (:require (clojure [template :refer [do-template]] + [string :as string]) [clojure.java.io :as io] [clojure.core.match :as M :refer [matchv]] clojure.core.match.array @@ -29,6 +30,7 @@ (def ^String version "0.2") (def ^String input-dir "source") (def ^String output-dir "target/jvm") +(def ^String output-package (str output-dir "/program.jar")) (def ^String function-class "lux/Function") (def ^String local-prefix "l") @@ -59,7 +61,31 @@ !classes &/classes :let [real-name (str (&host/->module-class module) "." name) _ (swap! !classes assoc real-name bytecode) - _ (load-class! loader real-name) _ (when (not eval?) - (write-output module name bytecode))]] + (write-output module name bytecode)) + _ (load-class! loader real-name)]] (return nil))) + +(do-template [ ] + (defn [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str (&host/->type-signature )))) + ;; (doto writer + ;; ;; X + ;; (.visitTypeInsn Opcodes/NEW ) ;; XW + ;; (.visitInsn ) ;; WXW + ;; (.visitInsn ) ;; WWXW + ;; (.visitInsn Opcodes/POP) ;; WWX + ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "" ) ;; W + ;; ) + ) + + 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 + ) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 57e81a2b0..c0d978146 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -55,8 +55,11 @@ (defn clean [state] "(-> Compiler (,))" (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set) - outdated? #(-> ^File % .getName (string/replace " " "/") (->> (contains? needed-modules)) not) - outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?))] + 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)] + (when (.exists program-file) + (.delete program-file)) (doseq [f outdate-files] (clean-file f)) nil)) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 3df09b29e..346b66fd2 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*] (matchv ::M/objects [*type*] - [["lux;VariantT" ["lux;Nil" _]]] + [["lux;TupleT" ["lux;Nil" _]]] (.visitInsn *writer* Opcodes/ACONST_NULL) [["lux;DataT" "boolean"]] @@ -84,7 +84,7 @@ *writer*)) ;; [Resources] -(do-template [ ] +(do-template [ ] (defn [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer @@ -98,32 +98,32 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) _ (doto *writer* (.visitInsn ) - (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ (str (&host/->type-signature ))))]] + ())]] (return nil))) - compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" + compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" &&/wrap-int + compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" &&/wrap-int + compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" &&/wrap-int + compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" &&/wrap-int + compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" &&/wrap-int - compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - - compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" + compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long + compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long + compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" &&/wrap-long + compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" &&/wrap-long + + compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" &&/wrap-float + compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" &&/wrap-float + compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" &&/wrap-float + compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" &&/wrap-float + compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" &&/wrap-float - compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" + compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" &&/wrap-double + compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" &&/wrap-double + compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" &&/wrap-double + compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" &&/wrap-double + compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" &&/wrap-double ) (do-template [ ] @@ -205,31 +205,50 @@ (return ret))) ?classes ?args) :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class ?class) ?method method-sig) + (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&type/as-obj ?class)) ?method method-sig) (prepare-return! *type*))]] (return nil))) (do-template [ ] (defn [compile *type* ?class ?method ?classes ?object ?args] - (|do [^MethodVisitor *writer* &/get-writer + (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] _ (&/map2% (fn [class-name arg] (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] (return ret))) ?classes ?args) :let [_ (doto *writer* - (.visitMethodInsn (&host/->class ?class) ?method method-sig) + (.visitMethodInsn ?class* ?method method-sig) (prepare-return! *type*))]] (return nil))) compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE - compile-jvm-invokespecial Opcodes/INVOKESPECIAL + ;; compile-jvm-invokespecial Opcodes/INVOKESPECIAL ) +(defn compile-jvm-invokespecial [compile *type* ?class ?method ?classes ?object ?args] + (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + _ (compile ?object) + ;; :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] + :let [_ (when (not= "" ?method) + (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESPECIAL ?class* ?method method-sig) + (prepare-return! *type*))]] + (return nil))) + (defn compile-jvm-null [compile *type*] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] @@ -293,31 +312,33 @@ (defn compile-jvm-getstatic [compile *type* ?class ?field] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*)) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*)) (prepare-return! *type*))]] (return nil))) (defn compile-jvm-getfield [compile *type* ?class ?field ?object] - (|do [^MethodVisitor *writer* &/get-writer + (|do [:let [class* (&host/->class (&type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class ?class)) - (.visitFieldInsn Opcodes/GETFIELD (&host/->class ?class) ?field (&host/->java-sig *type*)) + (.visitTypeInsn Opcodes/CHECKCAST class*) + (.visitFieldInsn Opcodes/GETFIELD class* ?field (&host/->java-sig *type*)) (prepare-return! *type*))]] (return nil))) (defn compile-jvm-putstatic [compile *type* ?class ?field ?value] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?value) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*))]] (return nil))) (defn compile-jvm-putfield [compile *type* ?class ?field ?object ?value] - (|do [^MethodVisitor *writer* &/get-writer + (|do [:let [class* (&host/->class (&type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer _ (compile ?object) _ (compile ?value) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] - :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig *type*))]] (return nil))) (defn ^:private modifiers->int [mods] @@ -336,11 +357,12 @@ 0))) (defn compile-jvm-instanceof [compile *type* class object] - (|do [^MethodVisitor *writer* &/get-writer + (|do [:let [class* (&host/->class class)] + ^MethodVisitor *writer* &/get-writer _ (compile object) :let [_ (doto *writer* - (.visitLdcInsn class) - (.visitTypeInsn Opcodes/INSTANCEOF class))]] + (.visitTypeInsn Opcodes/INSTANCEOF class*) + (&&/wrap-boolean))]] (return nil))) (defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods] @@ -391,46 +413,50 @@ $to (new Label) $end (new Label) $catch-finally (new Label) - compile-finally (if ?finally - (|do [_ (return nil) - _ (compile ?finally) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) - (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) - _ (.visitLabel *writer* $from)] + compile-finally (matchv ::M/objects [?finally] + [["lux;Some" ?finally*]] (|do [_ (return nil) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) + [["lux;None" _]] (|do [_ (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) + ;; :let [_ (prn 'HANDLER ?ex-class (&host/->class ?ex-class) $handler-start $handler-end $from $to $catch-finally)] + ] + (doto *writer* + (.visitTryCatchBlock $from $to $handler-start (&host/->class ?ex-class)) + (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil))) + _ (.visitTryCatchBlock *writer* $from $to $catch-finally nil)] + :let [_ (.visitLabel *writer* $from)] _ (compile ?body) :let [_ (.visitLabel *writer* $to)] _ compile-finally - handlers (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [:let [$handler-start (new Label) - $handler-end (new Label)] - _ (compile ?catch-body) - :let [_ (.visitLabel *writer* $handler-end)] - _ compile-finally] - (return [?ex-class $handler-start $handler-end]))) - ?catches) + handlers (&/map2% (fn [[?ex-class ?ex-idx ?catch-body] [_ $handler-start $handler-end]] + (|do [:let [_ (doto *writer* + (.visitLabel $handler-start) + (.visitVarInsn Opcodes/ASTORE ?ex-idx))] + _ (compile ?catch-body) + :let [_ (.visitLabel *writer* $handler-end)]] + compile-finally)) + ?catches + catch-boundaries) + ;; :let [_ (prn 'handlers (&/->seq handlers))] :let [_ (.visitLabel *writer* $catch-finally)] - _ (if ?finally - (|do [_ (compile ?finally) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitInsn Opcodes/ATHROW))]] - (return nil)) - (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + _ (matchv ::M/objects [?finally] + [["lux;Some" ?finally*]] (|do [_ (compile ?finally*) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) + [["lux;None" _]] (|do [_ (return nil) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] - :let [_ (.visitLabel *writer* $end)] - :let [_ (doseq [[?ex-class $handler-start $handler-end] handlers] - (doto *writer* - (.visitTryCatchBlock $from $to $handler-start ?ex-class) - (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil)) - ) - _ (.visitTryCatchBlock *writer* $from $to $catch-finally nil)]] + :let [_ (.visitLabel *writer* $end)]] (return nil))) (defn compile-jvm-throw [compile *type* ?ex] @@ -518,12 +544,17 @@ ) (defn compile-jvm-program [compile ?body] - (|do [^ClassWriter *writer* &/get-writer] + (|do [module-name &/get-module-name + ;; :let [_ (prn 'compile-jvm-program module-name)] + ^ClassWriter *writer* &/get-writer] (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) (.visitCode)) (|do [^MethodVisitor main-writer &/get-writer - :let [$loop (new Label) + :let [;; _ (prn "#1" module-name *writer*) + $loop (new Label) + ;; _ (prn "#2") $end (new Label) + ;; _ (prn "#3") _ (doto main-writer ;; Tail: Begin (.visitLdcInsn (int 2)) ;; S @@ -589,14 +620,21 @@ (.visitLabel $end) ;; VI (.visitInsn Opcodes/POP) ;; V (.visitVarInsn Opcodes/ASTORE (int 0)) ;; - )] + ) + ;; _ (prn "#4") + ] _ (compile ?body) - :let [_ (doto main-writer + :let [;; _ (prn "#5") + _ (doto main-writer (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature))] + (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature)) + ;; _ (prn "#6") + ] :let [_ (doto main-writer - (.visitInsn Opcodes/POP) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] + (.visitInsn Opcodes/POP) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + ;; _ (prn "#7") + ]] (return nil))))) diff --git a/src/lux/compiler/package.clj b/src/lux/compiler/package.clj new file mode 100644 index 000000000..40639e85a --- /dev/null +++ b/src/lux/compiler/package.clj @@ -0,0 +1,61 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.compiler.package + (:require [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail*]] + [host :as &host]) + (lux.compiler [base :as &&])) + (:import (java.io File + FileInputStream + FileOutputStream + BufferedInputStream) + (java.util.jar Manifest + Attributes$Name + JarEntry + JarOutputStream + ))) + +;; [Utils] +(def ^:private kilobyte 1024) + +(defn ^:private manifest [^String module] + "(-> Text Manifest)" + (doto (new Manifest) + (-> .getMainAttributes (doto (.put Attributes$Name/MAIN_CLASS (str (&host/->module-class module) "._")) + (.put Attributes$Name/MANIFEST_VERSION "1.0"))))) + +(defn ^:private write-class! [^String path ^File file ^JarOutputStream out] + "(-> Text File JarOutputStream Unit)" + (with-open [in (new BufferedInputStream (new FileInputStream file))] + (let [buffer (byte-array (* 10 kilobyte))] + (doto out + (.putNextEntry (new JarEntry (str path "/" (.getName file)))) + (-> (.write buffer 0 bytes-read) + (->> (when (not= -1 bytes-read)) + (loop [bytes-read (.read in buffer)]))) + (.flush) + (.closeEntry) + )) + )) + +(defn ^:private write-module! [^File file ^JarOutputStream out] + "(-> File JarOutputStream Unit)" + (let [module-name (.getName file)] + (doseq [$class (.listFiles file)] + (write-class! module-name $class out)))) + +;; [Resources] +(defn package [module] + "(-> Text (,))" + ;; (prn 'package module) + (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] + (doseq [$group (.listFiles (new File &&/output-dir))] + (write-module! $group out)) + )) diff --git a/src/lux/host.clj b/src/lux/host.clj index cf9830169..906e3c714 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -18,6 +18,7 @@ ;; [Constants] (def prefix "lux.") (def function-class (str prefix "Function")) +(def module-separator "_") ;; [Utils] (defn ^:private class->type [^Class class] @@ -27,7 +28,7 @@ "") (.getSimpleName class)))] (if (.equals "void" base) - (return &type/$Void) + (return &type/Unit) (return (&/V "lux;DataT" (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) base))) ))) @@ -40,7 +41,7 @@ (string/replace class #"\." "/")) (defn ^String ->module-class [module-name] - (string/replace module-name #"/" " ")) + (string/replace module-name #"/" module-separator)) (def ->package ->module-class) @@ -71,13 +72,13 @@ [["lux;LambdaT" [_ _]]] (->type-signature function-class) - [["lux;VariantT" ["lux;Nil" _]]] + [["lux;TupleT" ["lux;Nil" _]]] "V" )) (do-template [ ] - (defn [target field] - (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName target)) + (defn [class-loader target field] + (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&type/as-obj target) true class-loader)) :when (and (.equals ^Object field (.getName =field)) (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] (.getType =field)))] @@ -90,8 +91,9 @@ ) (do-template [ ] - (defn [target method-name args] - (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName target)) + (defn [class-loader target method-name args] + ;; (prn ' target method-name) + (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj target) true class-loader)) :when (and (.equals ^Object method-name (.getName =method)) (.equals ^Object (Modifier/isStatic (.getModifiers =method))) (&/fold2 #(and %1 (.equals ^Object %2 %3)) diff --git a/src/lux/type.clj b/src/lux/type.clj index af2bbf30f..f5b8d3f25 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -587,12 +587,24 @@ [_] (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) -(def init-fixpoints (&/|list)) - -(def counter (atom {})) -(defn ^:private check* [fixpoints expected actual] - ;; (swap! counter update-in [[(aget expected 0) (aget actual 0)]] - ;; #(inc (or % 0))) +(defn as-obj [class] + (case class + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + class)) + +(def ^:private primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}) + +(def ^:private init-fixpoints (&/|list)) + +(defn ^:private check* [class-loader fixpoints expected actual] (if (clojure.lang.Util/identical expected actual) (return (&/T fixpoints nil)) (matchv ::M/objects [expected actual] @@ -619,13 +631,13 @@ (return (&/T fixpoints nil))) [["lux;Some" etype] ["lux;None" _]] - (check* fixpoints etype actual) + (check* class-loader fixpoints etype actual) [["lux;None" _] ["lux;Some" atype]] - (check* fixpoints expected atype) + (check* class-loader fixpoints expected atype) [["lux;Some" etype] ["lux;Some" atype]] - (check* fixpoints etype atype)))) + (check* class-loader fixpoints etype atype)))) [["lux;VarT" ?id] _] (fn [state] @@ -635,7 +647,7 @@ [["lux;Left" _]] ((|do [bound (deref ?id)] - (check* fixpoints bound actual)) + (check* class-loader fixpoints bound actual)) state))) [_ ["lux;VarT" ?id]] @@ -646,7 +658,7 @@ [["lux;Left" _]] ((|do [bound (deref ?id)] - (check* fixpoints expected bound)) + (check* class-loader fixpoints expected bound)) state))) [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] @@ -654,13 +666,13 @@ (matchv ::M/objects [((|do [F1 (deref ?eid)] (fn [state] (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" _]] - ((check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) state)))) state)] [["lux;Right" [state* output]]] @@ -668,62 +680,62 @@ [["lux;Left" _]] (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" _]] - ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - [fixpoints** _] (check* fixpoints* A1 A2)] + ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + [fixpoints** _] (check* class-loader fixpoints* A1 A2)] (return (&/T fixpoints** nil))) state)))) - ;; (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - ;; _ (check* fixpoints A1 A2)] + ;; (|do [_ (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + ;; _ (check* class-loader fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] (fn [state] (matchv ::M/objects [((|do [F1 (deref ?id)] - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" _]] - ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) - [fixpoints** _] (check* fixpoints* e* a*)] + [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) - ;; [fixpoints** _] (check* fixpoints* e* a*)] + ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] (fn [state] (matchv ::M/objects [((|do [F2 (deref ?id)] - (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" _]] - ((|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) - [fixpoints** _] (check* fixpoints* e* a*)] + [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) - ;; [fixpoints** _] (check* fixpoints* e* a*)] + ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) [["lux;AppT" [F A]] _] @@ -745,85 +757,44 @@ [["lux;None" _]] (|do [expected* (apply-type F A)] - (check* (fp-put fp-pair true fixpoints) expected* actual)))) + (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) [_ ["lux;AppT" [F A]]] (|do [actual* (apply-type F A)] - (check* fixpoints expected actual*)) + (check* class-loader fixpoints expected actual*)) [["lux;AllT" _] _] (with-var (fn [$arg] (|do [expected* (apply-type expected $arg)] - (check* fixpoints expected* actual)))) + (check* class-loader fixpoints expected* actual)))) [_ ["lux;AllT" _]] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg)] - (check* fixpoints expected actual*)))) - - [["lux;DataT" "boolean"] ["lux;DataT" "java.lang.Boolean"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "byte"] ["lux;DataT" "java.lang.Byte"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "short"] ["lux;DataT" "java.lang.Short"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "int"] ["lux;DataT" "java.lang.Integer"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "long"] ["lux;DataT" "java.lang.Long"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "float"] ["lux;DataT" "java.lang.Float"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "double"] ["lux;DataT" "java.lang.Double"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "char"] ["lux;DataT" "java.lang.Character"]] - (return (&/T fixpoints nil)) + (check* class-loader fixpoints expected actual*)))) - [["lux;DataT" "java.lang.Boolean"] ["lux;DataT" "boolean"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Byte"] ["lux;DataT" "byte"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Short"] ["lux;DataT" "short"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Integer"] ["lux;DataT" "int"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Long"] ["lux;DataT" "long"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Float"] ["lux;DataT" "float"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Double"] ["lux;DataT" "double"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Character"] ["lux;DataT" "char"]] - (return (&/T fixpoints nil)) + [["lux;DataT" e!name] ["lux;DataT" "null"]] + (if (contains? primitive-types e!name) + (fail (str "[Type Error] Can't use \"null\" with primitive types.")) + (return (&/T fixpoints nil))) [["lux;DataT" e!name] ["lux;DataT" a!name]] - (if (or (.equals ^Object e!name a!name) - (.isAssignableFrom (Class/forName e!name) (Class/forName a!name))) - (return (&/T fixpoints nil)) - (fail (str "[Type Error] Names don't match: " e!name " =/= " 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)) + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] - (|do [[fixpoints* _] (check* fixpoints aI eI)] - (check* fixpoints* eO aO)) + (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] + (check* class-loader fixpoints* eO aO)) [["lux;TupleT" e!members] ["lux;TupleT" a!members]] (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* fp e a)] + (|do [[fp* _] (check* class-loader fp e a)] (return fp*))) fixpoints e!members a!members)] @@ -834,7 +805,7 @@ (|let [[e!name e!type] e!case [a!name a!type] a!case] (if (.equals ^Object e!name a!name) - (|do [[fp* _] (check* fp e!type a!type)] + (|do [[fp* _] (check* class-loader fp e!type a!type)] (return fp*)) (fail (check-error expected actual))))) fixpoints @@ -846,7 +817,7 @@ (|let [[e!name e!type] e!slot [a!name a!type] a!slot] (if (.equals ^Object e!name a!name) - (|do [[fp* _] (check* fp e!type a!type)] + (|do [[fp* _] (check* class-loader fp e!type a!type)] (return fp*)) (fail (check-error expected actual))))) fixpoints @@ -863,7 +834,8 @@ ))) (defn check [expected actual] - (|do [_ (check* init-fixpoints expected actual)] + (|do [class-loader &/loader + _ (check* class-loader init-fixpoints expected actual)] (return nil))) (defn apply-lambda [func param] -- cgit v1.2.3 From 3bf6cc274a81821243a68b3bd81e88e6a8c2a07a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 29 Jul 2015 20:34:03 -0400 Subject: Updated the README for v0.2 --- README.md | 673 ++------------------------------------------------------------ 1 file changed, 18 insertions(+), 655 deletions(-) diff --git a/README.md b/README.md index 0040c8b9f..094de9d8d 100644 --- a/README.md +++ b/README.md @@ -5,37 +5,34 @@ It's meant to be a functional, statically-typed Lisp that will run on several pl ### What's the current version? -v0.1 +v0.2 ### How far ahead is the project? -The Java-bytecode compiler is close to completion. +The Java-bytecode compiler is almost complete. -Some features are missing and the compiler is not as fast as I would like. +A few features are missing and the compiler is not as fast as I would like. -However, some small programs can be written to try out Lux and get a feeling for the language. +However, programs can be written to try out Lux and get a feeling for the language. ### How can I use it? -Download the 0.1 compiler from here: https://github.com/LuxLang/lux/releases/download/0.1.0/lux-jvm-0.1.0-standalone.jar +Download the 0.2 compiler from here: https://github.com/LuxLang/lux/releases/download/0.2.0/lux-jvm-0.2.0-standalone.jar -Right now, the current version of Lux (0.1) is mostly to play around with the language, so it's a bit limited on what you can do. Once you download the compiler, you'll want to create a directory named "source" in the same directory where the compiler is located. -"source" must contain 2 files. -One will be the Lux prelude (lux.lux), the other will be program.lux -You can write anything you want inside program.lux to play around with the language. +You can run the compiler like this: -##### Note: You can download the lux.lux & program.lux files in the source/ directory in this repo to get started. + java -jar -Xss4m lux-jvm-0.2.0-standalone.jar program -To run the compiler, open your terminal and write this: +The **program** module is already inside **source/** to make it easier to start. - java -jar lux-jvm-0.1.0-standalone.jar +##### Note: You can download all the files inside the source/ directory in this repo to get started. -This will generate a directory named "output" and put all the .class files there. -Then, you can package the program and run it using this: +This will generate a directory named "target" and put all the .class files there. +Then, you can run the program like this: - cd output && jar cvf program.jar * && java -cp "program.jar" program && cd .. + cd target/jvm/ && java -jar program.jar ### What's the license? @@ -87,7 +84,7 @@ Functions are curried and partial application is as simple as just applying a fu e.g. - (let [inc (int:+ 1)] + (let [inc (i+ 1)] (map inc (list 1 2 3 4 5))) ### Code portability @@ -105,15 +102,11 @@ The mechanism hasn't been added yet to the language (mainly because there's only ### Macros Unlike in most other lisps, Lux macros are monadic. -The **(Lux a)** type is the one responsibly for the magic by treading **CompilerState** instances through macros. +The **(Lux a)** type is the one responsibly for the magic by treading **Compiler** instances through macros. Macros must have the **Macro** type and then be declared as macros. However, just using the **defmacro** macro will take care of it for you. - -Also, in an upcoming release you'll get another macro for defining macros. -It will be named **defsyntax** and will use monadic parsing of AST tokens to parse the syntax. - -If you want to see how macros are implemented, you can take a look at *lux.lux*. +Alternatively, you can use the **defsyntax** macro, which also offers monadic parsing of AST tokens for convenience. ### Custom pattern-matching @@ -176,639 +169,9 @@ If you want to communicate with me directly, just email me at luxlisp@gmail.com Check out the Emacs plugin for it: https://github.com/LuxLang/lux-mode -## What's available? - -### Base syntax - -Comments - - ## This is a single-line comment - ## Multi-line comments are comming soon - -Bool (implemented as java.lang.Boolean) - - true - false - -Int (implemented as java.lang.Long) - - 1 - -20 - 12345 - -Real (implemented as java.lang.Double) - - 1.23 - -0.5 - -Char (implemented as java.lang.Character) - - #"a" - #"\n" - -Text (implemented as java.lang.String) - - "yolo" - "Hello\tWorld!" - -Forms - - (+ 1 2) - (lambda [x] (foo 10 x)) - -Symbols - - foo ## Unprefixed symbol (compiler will assume it's in the current module) - bar;baz ## Prefixed symbol (compiler will assume it's in the module specified by the prefix) - ;fold ## With just the semi-colon, compiler wil assume it's the same as lux;fold - ;;quux ## With 2 semi-colons, it will get automatically prefixed with the current-module - -Tags - - #Nil - #lux;Cons - #;Some - #;;MyTag - -Tuples - - [] - ["yolo" 10 true] - -Variants (aka sum-types, aka discriminated unions) - - #Nil - (#Cons [10 #Nil]) - -Records - - {#name "Lux" #awesome? true} - -### Types - (deftype Bool (^ java.lang.Boolean)) - - (deftype Int (^ java.lang.Long)) - - (deftype Real (^ java.lang.Double)) - - (deftype Char (^ java.lang.Character)) - - (deftype Text (^ java.lang.String)) - - (deftype Void (|)) - - (deftype Ident (, Text Text)) - - (deftype (List a) - (| #Nil - (#Cons (, a (List a))))) - - (deftype (Maybe a) - (| #None - (#Some a))) - - (deftype #rec Type - (| (#DataT Text) ## Host data-type - (#TupleT (List Type)) ## Tuple types - (#VariantT (List (, Text Type))) ## Sum-types - (#RecordT (List (, Text Type))) ## Records - (#LambdaT (, Type Type)) ## Function-types - (#BoundT Text) - (#VarT Int) ## Type variables - (#ExT Int) ## Existential types - (#AllT (, (Maybe (List (, Text Type))) ## Polymorphic types - Text Text Type)) - (#AppT (, Type Type)))) ## Application of polymorphic types - - (deftype (Meta m d) - (| (#Meta (, m d)))) - - (deftype Syntax ...) - - (deftype (Either l r) - (| (#Left l) - (#Right r))) - - (deftype Reader ...) - - (deftype LuxVar ...) - - (deftype CompilerState ...) - - (deftype (Lux a) - (-> CompilerState (Either Text (, CompilerState a)))) - - (deftype Macro - (-> (List Syntax) (Lux (List Syntax)))) - - (deftype (IO a) - (-> (,) a)) - -### Macros -###### defmacro -e.g. - - (defmacro #export (and tokens) - (case (reverse tokens) - (\ (list& last init)) - (return (: (List Syntax) - (list (fold (: (-> Syntax Syntax Syntax) - (lambda [post pre] - (` (if (~ pre) - true - (~ post))))) - last - init)))) - - _ - (fail "and requires >=1 clauses."))) - -###### comment -e.g. - - (comment 1 2 3 4) ## Same as not writing anything... - -###### list -e.g. - - (list 1 2 3) - => (#Cons [1 (#Cons [2 (#Cons [3 #Nil])])]) - -###### list& -e.g. - - (list& 0 (list 1 2 3)) - => (#Cons [0 (list 1 2 3)]) - -###### lambda -e.g. - - (def const - (lambda [x y] x)) - - (def const - (lambda const [x y] x)) - -###### let -e.g. - - (let [x (foo bar) - y (baz quux)] - ...) - -###### $ -e.g. - - ## Application of binary functions over variadic arguments. - ($ text:++ "Hello, " name ".\nHow are you?") - => (text:++ "Hello, " (text:++ name ".\nHow are you?")) - -###### |> -e.g. - - ## Piping - (|> elems (map ->text) (interpose " ") (fold text:++ "")) - => - (fold text:++ "" - (interpose " " - (map ->text elems))) - -###### if -e.g. - - (if true - "Oh, yeah!" - "Aw hell naw!") - -###### ^ -e.g. - - ## Macro to treat classes as types - (^ java.lang.Object) - -###### , -e.g. - - ## Tuples - (, Text Int Bool) - - (,) ## The empty tuple, aka "unit" - -###### | -e.g. - - (| #Yes #No) - - (|) ## The empty variant, aka "void" - -###### & -e.g. - - ## Records - (& #name Text - #age Int - #alive? Bool) - -###### -> -e.g. - - ## Function types - (-> Int Int Int) ## This is the type of a function that takes 2 Ints and returns an Int - -###### All -e.g. - - ## Universal quantification. - (All List [a] - (| #Nil - (#Cons (, a (List a))))) - - ## It must be explicit, unlike in Haskell. - ## Rank-n types will be possible as well as existential types - (All [a] - (-> a a)) - -###### type` - - ## This macro is not meant to be used directly. It's used by :, :!, deftype, struct, sig - -###### io - - ## Just makes sure whatever computation you do returns an IO type. It's here mostly for host-interop. - (io (println "Hello, World!")) - -###### : -e.g. - - ## The type-annotation macro - (: (List Int) (list 1 2 3)) - -###### :! -e.g. - - ## The type-coercion macro - (:! Dinosaur (list 1 2 3)) - -###### deftype -e.g. - - ## The type-definition macro - (deftype (List a) - (| #Nil - (#Cons (, a (List a))))) - -###### exec -e.g. - - ## Sequential execution of expressions (great for side-effects). - ## But please use the io macro to help keep the purity. - (io (exec - (println "#1") - (println "#2") - (println "#3") - "YOLO")) - -###### def -e.g. - - ## Macro for definining global constants/functions. - (def (rejoin-pair pair) - (-> (, Syntax Syntax) (List Syntax)) - (let [[left right] pair] - (list left right))) - -###### case -e.g. - - ## The pattern-matching macro. - ## Allows the usage of macros within the patterns to provide custom syntax. - (case (: (List Int) (list 1 2 3)) - (#Cons [x (#Cons [y (#Cons [z #Nil])])]) - (#Some ($ int:* x y z)) - - _ - #None) - - (case (: (List Int) (list 1 2 3)) - (\ (list x y z)) - (#Some ($ int:* x y z)) - - _ - #None) - - (deftype Weekday - (| #Monday - #Tuesday - #Wednesday - #Thursday - #Friday - #Saturday - #Sunday)) - - (def (weekend? day) - (-> Weekday Bool) - (case day - (\or #Saturday #Sunday) - true - - _ - false)) - -###### \ - - ## It's a special macro meant to be used with case - -###### \or - - ## It's a special macro meant to be used with case - -###### ` - - ## Quasi-quotation as a macro. Unquote (~) and unquote-splice (~@) must also be used as forms - e.g. - (` (def (~ name) - (lambda [(~@ args)] - (~ body)))) - -###### sig - - ## Not mean to be used directly. Prefer defsig - -###### struct - - ## Not mean to be used directly. Prefer defstruct - -###### defsig -e.g. - - ## Definition of signatures ala ML - (defsig #export (Ord a) - (: (-> a a Bool) - <) - (: (-> a a Bool) - <=) - (: (-> a a Bool) - >) - (: (-> a a Bool) - >=)) - -###### defstruct -e.g. - - ## Definition of structures ala ML - (defstruct #export Int:Ord (Ord Int) - (def (< x y) - (jvm-llt x y)) - (def (<= x y) - (or (jvm-llt x y) - (jvm-leq x y))) - (def (> x y) - (jvm-lgt x y)) - (def (>= x y) - (or (jvm-lgt x y) - (jvm-leq x y)))) - -###### and -e.g. - - (and true false true) ## => false - -###### or -e.g. - - (or true false true) ## => true - -###### alias-lux - - ## Just creates local aliases of everything defined & exported in lux.lux -e.g. - - (;alias-lux) - -###### using -e.g. - - ## The Lux equivalent to ML's open. - ## Opens up a structure and provides all the definitions as local variables. - (using Int:Ord - (< 5 10)) - -### Functions -###### fold - - (All [a b] - (-> (-> a b a) a (List b) a)) - - (fold text:++ "" (list "Hello, " "World!")) - => "Hello, World!" - -###### reverse - - (All [a] - (-> (List a) (List a))) - - (reverse (list 1 2 3)) - => (list 3 2 1) - -###### map - - (All [a b] - (-> (-> a b) (List a) (List b))) - - (map (int:+ 1) (list 1 2 3)) - => (list 2 3 4) - -###### any? - - (All [a] - (-> (-> a Bool) (List a) Bool)) - - (any? even? (list 1 2 3)) - => true - -###### . - - ## Function composition: (. f g) => (lambda [x] (f (g x))) - (All [a b c] - (-> (-> b c) (-> a b) (-> a c))) - -###### int:+ - - (-> Int Int Int) - -###### int:- - - (-> Int Int Int) - -###### int:* - - (-> Int Int Int) - -###### int:/ - - (-> Int Int Int) - -###### int:% - - (-> Int Int Int) - -###### int:= - - (-> Int Int Bool) - -###### int:> - - (-> Int Int Bool) - -###### int:< - - (-> Int Int Bool) - -###### real:+ - - (-> Real Real Real) - -###### real:- - - (-> Real Real Real) - -###### real:* - - (-> Real Real Real) - -###### real:/ - - (-> Real Real Real) - -###### real:% - - (-> Real Real Real) - -###### real:= - - (-> Real Real Bool) - -###### real:> - - (-> Real Real Bool) - -###### real:< - - (-> Real Real Bool) - -###### length - - ## List length - (All [a] - (-> (List a) Int)) - -###### not - - (-> Bool Bool) - -###### text:++ - - ## Text/string concatenation - (-> Text Text Text) - -###### get-module-name - - ## Obtain the name of the currently-compiling module while in a macro. - (Lux Text) - -###### find-macro - - ## Given the name of a macro, try to obtain it. - (-> Ident (Lux (Maybe Macro))) - -###### normalize - - ## Normalizes a name so if it lacks a module prefix, it gets the one of the current module. - (-> Ident (Lux Ident)) - -###### ->text - - (-> (^ java.lang.Object) Text) - -###### interpose - - (All [a] - (-> a (List a) (List a))) - -###### syntax:show - - ## Turn Lux syntax into user-readable text. (Note: it's not pretty-printed) - (-> Syntax Text) - -###### macro-expand - - ## The standard macro-expand function. - (-> Syntax (Lux (List Syntax))) - -###### gensym - - ## Can't forget gensym! - (-> Text (Lux Syntax)) - -###### macro-expand-1 - - (-> Syntax (Lux Syntax)) - -###### id - - (All [a] - (-> a a)) - -###### print - - ## Neither print or println return IO right now because I've yet to implement monads & do-notation - (-> Text (,)) - -###### println - - (-> Text (,)) - -###### some - - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - -### Signatures -###### Eq - - (defsig #export (Eq a) - (: (-> a a Bool) - =)) - -###### Show - - (defsig #export (Show a) - (: (-> a Text) - show)) - -###### Ord - - (defsig #export (Ord a) - (: (-> a a Bool) - <) - (: (-> a a Bool) - <=) - (: (-> a a Bool) - >) - (: (-> a a Bool) - >=)) - -### Structures -###### Int:Eq -###### Real:Eq - -###### Bool:Show -###### Int:Show -###### Real:Show -###### Char:Show +## Where do I learn Lux? -###### Int:Ord -###### Real:Ord +Just head to the wiki and check out the documentation for the currently available modules, and the tutorials. ## Caveats @@ -817,7 +180,7 @@ The compiler is not fully stable so you might get an error if you do anything fu Also, the error messages could really use an overhaul, so any error message you get will probably startle you. -Don't worry about it, version 0.2 will improve error reporting a lot. +Don't worry about it, version 0.3 will improve error reporting a lot. If you have any doubts, feel free to ask/complain in the Google Group. ### Tags -- cgit v1.2.3