From b0114f4871a6a2654fa2edc667a635a97ae76b19 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 16 Feb 2017 20:09:52 -0400 Subject: - Implemented several new procedures. - Improved Lux-to-JS interactions. - Parallel compilation works for the JS backend. - Added more primitive functionality to the JS runtime. - More common procedures. --- stdlib/test/test/lux.lux | 16 ++++++++-------- stdlib/test/test/lux/data/text.lux | 8 ++++---- stdlib/test/test/lux/math/complex.lux | 16 ++++++++-------- 3 files changed, 20 insertions(+), 20 deletions(-) (limited to 'stdlib/test') diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux index 9516ae317..92ed5e2ca 100644 --- a/stdlib/test/test/lux.lux +++ b/stdlib/test/test/lux.lux @@ -115,10 +115,10 @@ (|> x' (/ y) (* y) (= x')))) ))] - ["Nat" R;nat n.= n.+ n.- n.* n./ n.% n.> +0 +1 +1000000 %n (n.% +1000) id] - ["Int" R;int i.= i.+ i.- i.* i./ i.% i.> 0 1 1000000 %i (i.% 1000) id] - ["Real" R;real r.= r.+ r.- r.* r./ r.% r.> 0.0 1.0 1000000.0 %r id math;floor] - ["Deg" R;deg d.= d.+ d.- d.* d./ d.% d.> .0 (_lux_proc ["deg" "max-value"] []) (_lux_proc ["deg" "max-value"] []) %f id id] + ["Nat" R;nat n.= n.+ n.- n.* n./ n.% n.> +0 +1 +1000000 %n (n.% +1000) id] + ["Int" R;int i.= i.+ i.- i.* i./ i.% i.> 0 1 1000000 %i (i.% 1000) id] + ["Real" R;real r.= r.+ r.- r.* r./ r.% r.> 0.0 1.0 1000000.0 %r id math;floor] + ["Deg" R;deg d.= d.+ d.- d.* d./ d.% d.> .0 (_lux_proc ["deg" "max-value"] []) (_lux_proc ["deg" "max-value"] []) %f id id] ) (do-template [category rand-gen -> <- = %a %z] @@ -128,10 +128,10 @@ (assert "" (|> value -> <- (= value))))] - ["Int->Nat" R;int int-to-nat nat-to-int i.= (i.% 1000000) %i %n] - ["Nat->Int" R;nat nat-to-int int-to-nat n.= (n.% +1000000) %n %i] - ["Int->Real" R;int int-to-real real-to-int i.= (i.% 1000000) %i %r] - ["Real->Int" R;real real-to-int int-to-real r.= math;floor %r %i] + ["Int->Nat" R;int int-to-nat nat-to-int i.= (i.% 1000000) %i %n] + ["Nat->Int" R;nat nat-to-int int-to-nat n.= (n.% +1000000) %n %i] + ["Int->Real" R;int int-to-real real-to-int i.= (i.% 1000000) %i %r] + ["Real->Int" R;real real-to-int int-to-real r.= math;floor %r %i] ## [R;real real-to-deg deg-to-real r.= (r.% 1.0) %r %f] ) diff --git a/stdlib/test/test/lux/data/text.lux b/stdlib/test/test/lux/data/text.lux index fd847001e..8ddd27a7c 100644 --- a/stdlib/test/test/lux/data/text.lux +++ b/stdlib/test/test/lux/data/text.lux @@ -77,10 +77,10 @@ _ false)) - (|> [(&;sub +0 sizeL sample) - (&;sub sizeL (&;size sample) sample) - (&;sub' sizeL sample) - (&;sub' +0 sample)] + (|> [(&;clip +0 sizeL sample) + (&;clip sizeL (&;size sample) sample) + (&;clip' sizeL sample) + (&;clip' +0 sample)] (case> [(#;Right _l) (#;Right _r) (#;Right _r') (#;Right _f)] (and (= sampleL _l) (= sampleR _r) diff --git a/stdlib/test/test/lux/math/complex.lux b/stdlib/test/test/lux/math/complex.lux index 04ebcb3c0..f965f9214 100644 --- a/stdlib/test/test/lux/math/complex.lux +++ b/stdlib/test/test/lux/math/complex.lux @@ -54,8 +54,8 @@ (r.= imaginary (get@ #&;imaginary r+i))))) (assert "If either the real part or the imaginary part is NaN, the composite is NaN." - (and (&;nan? (&;complex number;nan imaginary)) - (&;nan? (&;complex real number;nan)))) + (and (&;not-a-number? (&;complex number;not-a-number imaginary)) + (&;not-a-number? (&;complex real number;not-a-number)))) )) (test: "Absolute value" @@ -69,14 +69,14 @@ (r.>= (r/abs imaginary) abs)))) (assert "The absolute value of a complex number involving a NaN on either dimension, results in a NaN value." - (and (number;nan? (get@ #&;real (&;c.abs (&;complex number;nan imaginary)))) - (number;nan? (get@ #&;real (&;c.abs (&;complex real number;nan)))))) + (and (number;not-a-number? (get@ #&;real (&;c.abs (&;complex number;not-a-number imaginary)))) + (number;not-a-number? (get@ #&;real (&;c.abs (&;complex real number;not-a-number)))))) (assert "The absolute value of a complex number involving an infinity on either dimension, results in an infinite value." - (and (r.= number;+inf (get@ #&;real (&;c.abs (&;complex number;+inf imaginary)))) - (r.= number;+inf (get@ #&;real (&;c.abs (&;complex real number;+inf)))) - (r.= number;+inf (get@ #&;real (&;c.abs (&;complex number;-inf imaginary)))) - (r.= number;+inf (get@ #&;real (&;c.abs (&;complex real number;-inf)))))) + (and (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex number;positive-infinity imaginary)))) + (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex real number;positive-infinity)))) + (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex number;negative-infinity imaginary)))) + (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex real number;negative-infinity)))))) )) (test: "Addidion, substraction, multiplication and division" -- cgit v1.3.1 From 38a81332a1cefb51ff89ee96a16bb4a65cee21bc Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 22 Feb 2017 18:01:05 -0400 Subject: - Implemented a variety of new procedures for text, chars, math and arrays. --- luxc/src/lux/analyser/proc/common.clj | 140 +++++++++++++++++--- luxc/src/lux/compiler/js/proc/common.clj | 150 ++++++++++++++++------ luxc/src/lux/compiler/js/rt.clj | 36 +++++- luxc/src/lux/compiler/jvm/proc/common.clj | 206 +++++++++++++++++++++++++++--- stdlib/source/lux.lux | 18 ++- stdlib/source/lux/data/char.lux | 50 ++++---- stdlib/source/lux/data/number.lux | 3 +- stdlib/source/lux/data/text.lux | 84 ++++++------ stdlib/source/lux/math.lux | 62 ++++----- stdlib/test/test/lux/data/text.lux | 8 +- 10 files changed, 564 insertions(+), 193 deletions(-) (limited to 'stdlib/test') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index bec0855e1..9ab01801f 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -28,25 +28,38 @@ (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool + ^:private analyse-text-lt ["text" "<"] &type/Text &type/Bool ^:private analyse-text-append ["text" "append"] &type/Text &type/Text ) -(do-template [ ] +(do-template [ ] (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons text (&/$Cons part (&/$Nil))) ?values] + (|do [:let [(&/$Cons text (&/$Cons part (&/$Cons start (&/$Nil)))) ?values] =text (&&/analyse-1 analyse &type/Text text) =part (&&/analyse-1 analyse &type/Text part) - _ (&type/check exo-type (&/$AppT &type/Maybe &type/Nat)) + =start (&&/analyse-1 analyse &type/Nat start) + _ (&type/check exo-type ) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["text" ]) - (&/|list =text =part) + (&/|list =text =part =start) (&/|list))))))) - ^:private analyse-text-index "index" - ^:private analyse-text-last-index "last-index" + ^:private analyse-text-index "index" (&/$AppT &type/Maybe &type/Nat) + ^:private analyse-text-last-index "last-index" (&/$AppT &type/Maybe &type/Nat) ) +(defn ^:private analyse-text-contains? [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Cons part (&/$Nil))) ?values] + =text (&&/analyse-1 analyse &type/Text text) + =part (&&/analyse-1 analyse &type/Text part) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" "contains?"]) + (&/|list =text =part) + (&/|list))))))) + (defn ^:private analyse-text-clip [analyse exo-type ?values] (|do [:let [(&/$Cons text (&/$Cons from (&/$Cons to (&/$Nil)))) ?values] =text (&&/analyse-1 analyse &type/Text text) @@ -71,15 +84,20 @@ (&/|list =text =to-find =replace-with) (&/|list))))))) -(defn ^:private analyse-text-size [analyse exo-type ?values] - (|do [:let [(&/$Cons text (&/$Nil)) ?values] - =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["text" "size"]) - (&/|list =text) - (&/|list))))))) +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Nil)) ?values] + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" ]) + (&/|list =text) + (&/|list))))))) + + ^:private analyse-text-size "size" + ^:private analyse-text-hash "hash" + ) (do-template [ ] (defn [analyse exo-type ?values] @@ -187,6 +205,9 @@ ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool + + ^:private analyse-char-eq ["char" "="] &type/Char &type/Bool + ^:private analyse-char-lt ["char" "<"] &type/Char &type/Bool ) (defn ^:private analyse-deg-scale [analyse exo-type ?values] @@ -328,6 +349,61 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["array" "size"]) (&/|list =array) (&/|list))))))))) +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["math" ]) (&/|list) (&/|list))))))) + + ^:private analyse-math-e "e" + ^:private analyse-math-pi "pi" + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + =input (&&/analyse-1 analyse &type/Real ?input) + _ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["math" ]) (&/|list =input) (&/|list))))))) + + ^:private analyse-math-cos "cos" + ^:private analyse-math-sin "sin" + ^:private analyse-math-tan "tan" + ^:private analyse-math-acos "acos" + ^:private analyse-math-asin "asin" + ^:private analyse-math-atan "atan" + ^:private analyse-math-cosh "cosh" + ^:private analyse-math-sinh "sinh" + ^:private analyse-math-tanh "tanh" + ^:private analyse-math-exp "exp" + ^:private analyse-math-log "log" + ^:private analyse-math-root2 "root2" + ^:private analyse-math-root3 "root3" + ^:private analyse-math-degrees "degrees" + ^:private analyse-math-radians "radians" + ^:private analyse-math-ceil "ceil" + ^:private analyse-math-floor "floor" + ^:private analyse-math-round "round" + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + =input (&&/analyse-1 analyse &type/Real ?input) + =param (&&/analyse-1 analyse &type/Real ?param) + _ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["math" ]) (&/|list =input =param) (&/|list))))))) + + ^:private analyse-math-atan2 "atan2" + ^:private analyse-math-pow "pow" + ) + (defn analyse-proc [analyse exo-type category proc ?values] (case category "lux" @@ -342,16 +418,20 @@ "text" (case proc "=" (analyse-text-eq analyse exo-type ?values) + "<" (analyse-text-lt analyse exo-type ?values) "append" (analyse-text-append analyse exo-type ?values) "clip" (analyse-text-clip analyse exo-type ?values) "index" (analyse-text-index analyse exo-type ?values) "last-index" (analyse-text-last-index analyse exo-type ?values) "size" (analyse-text-size analyse exo-type ?values) + "hash" (analyse-text-hash analyse exo-type ?values) "replace-all" (analyse-text-replace-all analyse exo-type ?values) "trim" (analyse-text-trim analyse exo-type ?values) "char" (analyse-text-char analyse exo-type ?values) "upper-case" (analyse-text-upper-case analyse exo-type ?values) - "lower-case" (analyse-text-lower-case analyse exo-type ?values)) + "lower-case" (analyse-text-lower-case analyse exo-type ?values) + "contains?" (analyse-text-contains? analyse exo-type ?values) + ) "bit" (case proc @@ -445,9 +525,37 @@ "char" (case proc + "=" (analyse-char-eq analyse exo-type ?values) + "<" (analyse-char-lt analyse exo-type ?values) "to-text" (analyse-char-to-text analyse exo-type ?values) "to-nat" (analyse-char-to-nat analyse exo-type ?values) ) + + "math" + (case proc + "e" (analyse-math-e analyse exo-type ?values) + "pi" (analyse-math-pi analyse exo-type ?values) + "cos" (analyse-math-cos analyse exo-type ?values) + "sin" (analyse-math-sin analyse exo-type ?values) + "tan" (analyse-math-tan analyse exo-type ?values) + "acos" (analyse-math-acos analyse exo-type ?values) + "asin" (analyse-math-asin analyse exo-type ?values) + "atan" (analyse-math-atan analyse exo-type ?values) + "cosh" (analyse-math-cosh analyse exo-type ?values) + "sinh" (analyse-math-sinh analyse exo-type ?values) + "tanh" (analyse-math-tanh analyse exo-type ?values) + "exp" (analyse-math-exp analyse exo-type ?values) + "log" (analyse-math-log analyse exo-type ?values) + "root2" (analyse-math-root2 analyse exo-type ?values) + "root3" (analyse-math-root3 analyse exo-type ?values) + "degrees" (analyse-math-degrees analyse exo-type ?values) + "radians" (analyse-math-radians analyse exo-type ?values) + "ceil" (analyse-math-ceil analyse exo-type ?values) + "floor" (analyse-math-floor analyse exo-type ?values) + "round" (analyse-math-round analyse exo-type ?values) + "atan2" (analyse-math-atan2 analyse exo-type ?values) + "pow" (analyse-math-pow analyse exo-type ?values) + ) ;; else (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index ee381add4..11fb9fd95 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -69,6 +69,43 @@ =right (compile ?right)] (return (str "(" =left " === " =right ")")))) +(defn ^:private compile-array-new [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values] + =length (compile ?length)] + (return (str "new Array(" (str "LuxRT.toNumberI64(" =length ")") ")")))) + +(defn ^:private compile-array-get [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array) + =idx (compile ?idx)] + (return (str "LuxRT.arrayGet(" =array "," =idx ")")))) + +(defn ^:private compile-array-put [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array) + =idx (compile ?idx) + =elem (compile ?elem)] + (return (str "LuxRT.arrayPut(" =array "," =idx "," =elem ")")))) + +(defn ^:private compile-array-remove [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array) + =idx (compile ?idx)] + (return (str "LuxRT.arrayRemove(" =array "," =idx ")")))) + +(defn ^:private compile-array-size [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array)] + (return (str =array ".length")))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -134,10 +171,14 @@ ^:private compile-deg-decode "decodeD64" ^:private compile-real-decode "decodeReal" - - ^:private compile-real-hash "hashReal" ) +(defn ^:private compile-real-hash [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str &&rt/LuxRT ".textHash(''+" =x ")")) + )) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Nil) ?values]] @@ -222,28 +263,6 @@ ;; ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long ;; ) -;; (let [widen (fn [^MethodVisitor *writer*] -;; (doto *writer* -;; (.visitInsn Opcodes/I2L))) -;; shrink (fn [^MethodVisitor *writer*] -;; (doto *writer* -;; (.visitInsn Opcodes/L2I) -;; (.visitInsn Opcodes/I2C)))] -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; -;; -;; )]] -;; (return nil))) - -;; ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink -;; ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen -;; )) - (do-template [] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] @@ -273,11 +292,27 @@ =x (compile ?x)] (return (str "LuxRT.realToDeg(" =x ")")))) -(defn ^:private compile-text-eq [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str "(" =x "===" =y ")")))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x =y ")")))) + + ^:private compile-text-eq "===" + ^:private compile-text-lt "<" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x ".C" " " " " =y ".C" ")")))) + + ^:private compile-char-eq "===" + ^:private compile-char-lt "<" + ) (defn ^:private compile-text-append [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -287,15 +322,26 @@ (do-template [ ] (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] =text (compile ?text) - =part (compile ?part)] - (return (str "LuxRT" "." "(" =text "," =part ")")))) + =part (compile ?part) + =start (compile ?start)] + (return (str "LuxRT" "." "(" =text "," =part "," =start ")")))) ^:private compile-text-last-index "lastIndex" ^:private compile-text-index "index" ) +(defn ^:private compile-text-contains? [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + =text (compile ?text) + =part (compile ?part)] + (return (str "(" (str (str "(" =text ")") + ".indexOf" + (str "(" =part ")")) + " !== " "-1" + ")")))) + (defn ^:private compile-text-clip [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?from (&/$Cons ?to (&/$Nil)))) ?values] =text (compile ?text) @@ -315,6 +361,11 @@ =text (compile ?text)] (return (str "LuxRT.fromNumberI64(" =text ".length" ")")))) +(defn ^:private compile-text-hash [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + =text (compile ?text)] + (return (str "LuxRT.textHash(" =text ")")))) + (defn ^:private compile-text-char [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values] =text (compile ?text) @@ -337,6 +388,20 @@ =x (compile ?x)] (return (str "(" =x ").C")))) +(defn ^:private compile-char-to-nat [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "LuxRT.fromNumberI64(" (str "(" =x ").C" ".charCodeAt(0)") ")")))) + +(defn ^:private compile-nat-to-char [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "{C:" + (str "String.fromCharCode(" + (str "LuxRT.toNumberI64(" =x ")") + ")") + "}")))) + (defn ^:private compile-lux-log [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] =message (compile ?message)] @@ -361,16 +426,19 @@ "text" (case proc-name "=" (compile-text-eq compile ?values special-args) + "<" (compile-text-lt compile ?values special-args) "append" (compile-text-append compile ?values special-args) "clip" (compile-text-clip compile ?values special-args) "index" (compile-text-index compile ?values special-args) "last-index" (compile-text-last-index compile ?values special-args) "size" (compile-text-size compile ?values special-args) + "hash" (compile-text-hash compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) "char" (compile-text-char compile ?values special-args) "upper-case" (compile-text-upper-case compile ?values special-args) "lower-case" (compile-text-lower-case compile ?values special-args) + "contains?" (compile-text-contains? compile ?values special-args) ) ;; "bit" @@ -383,9 +451,13 @@ ;; "shift-right" (compile-bit-shift-right compile ?values special-args) ;; "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) - ;; "array" - ;; (case proc-name - ;; "get" (compile-array-get compile ?values special-args)) + "array" + (case proc-name + "new" (compile-array-new compile ?values special-args) + "get" (compile-array-get compile ?values special-args) + "put" (compile-array-put compile ?values special-args) + "remove" (compile-array-remove compile ?values special-args) + "size" (compile-array-size compile ?values special-args)) "nat" (case proc-name @@ -401,7 +473,7 @@ "max-value" (compile-nat-max-value compile ?values special-args) "min-value" (compile-nat-min-value compile ?values special-args) "to-int" (compile-nat-to-int compile ?values special-args) - ;; "to-char" (compile-nat-to-char compile ?values special-args) + "to-char" (compile-nat-to-char compile ?values special-args) ) "int" @@ -461,8 +533,10 @@ "char" (case proc-name - "to-text" (compile-char-to-text compile ?values special-args) - ;; "to-nat" (compile-char-to-nat compile ?values special-args) + "=" (compile-char-eq compile ?values special-args) + "<" (compile-char-lt compile ?values special-args) + "to-text" (compile-char-to-text compile ?values special-args) + "to-nat" (compile-char-to-nat compile ?values special-args) ) ;; else diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index eaac37a6a..cc00e2908 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -1233,8 +1233,8 @@ (str "[1,''," value "]")) (def ^:private text-methods - {"index" (str "(function index(text,part) {" - "var idx = text.indexOf(part);" + {"index" (str "(function index(text,part,start) {" + "var idx = text.indexOf(part,LuxRT.toNumberI64(start));" (str (str "if(idx === -1) {" "return " const-none ";" "}") @@ -1242,8 +1242,8 @@ (str "return " (make-some "LuxRT.fromNumberI64(idx)") ";") "}")) "})") - "lastIndex" (str "(function lastIndex(text,part) {" - "var idx = text.lastIndexOf(part);" + "lastIndex" (str "(function lastIndex(text,part,start) {" + "var idx = text.lastIndexOf(part,LuxRT.toNumberI64(start));" (str (str "if(idx === -1) {" "return " const-none ";" "}") @@ -1275,6 +1275,33 @@ "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" "})") + "textHash" (str "(function(input) {" + "var hash = 0;" + (str "for(var i = 0; i < input.length; i++) {" + "hash = (((hash << 5) - hash) + input.charCodeAt(i)) & 0xFFFFFFFF;" + "}") + "return LuxRT.fromNumberI64(hash);" + "})") + }) + +(def ^:private array-methods + {"arrayGet" (str "(function arrayGet(arr,idx) {" + "var temp = arr[LuxRT.toNumberI64(idx)];" + (str "if(temp !== undefined) {" + (str "return " (make-some "temp") ";") + "}" + "else {" + (str "return " const-none ";") + "}") + "})") + "arrayPut" (str "(function arrayPut(arr,idx,val) {" + "arr[LuxRT.toNumberI64(idx)] = val;" + "return arr;" + "})") + "arrayRemove" (str "(function arrayRemove(arr,idx) {" + "delete arr[LuxRT.toNumberI64(idx)];" + "return arr;" + "})") }) (def LuxRT "LuxRT") @@ -1285,6 +1312,7 @@ i64-methods n64-methods text-methods + array-methods io-methods) (map (fn [[key val]] (str key ":" val))) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 01048fd98..63e7b9e76 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -265,6 +265,31 @@ ^:private compile-real-lt Opcodes/DCMPG -1 &&/unwrap-double ) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + ) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-char-eq Opcodes/IF_ICMPEQ &&/unwrap-char + ^:private compile-char-lt Opcodes/IF_ICMPLT &&/unwrap-char + ) + (defn ^:private compile-real-hash [compile ?values special-args] (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer @@ -496,7 +521,7 @@ ^:private compile-int-to-real &&/unwrap-long Opcodes/L2D &&/wrap-double ) -(defn compile-text-eq [compile ?values special-args] +(defn ^:private compile-text-eq [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?x) @@ -506,6 +531,28 @@ (&&/wrap-boolean))]] (return nil))) +(defn ^:private compile-text-lt [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "compareTo" "(Ljava/lang/String;)I") + (.visitLdcInsn (int -1)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + (defn compile-text-append [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer @@ -539,7 +586,7 @@ (do-template [ ] (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?text) :let [_ (doto *writer* @@ -547,8 +594,12 @@ _ (compile ?part) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?start) :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "(Ljava/lang/String;)I"))] + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "(Ljava/lang/String;I)I"))] :let [$not-found (new Label) $end (new Label) _ (doto *writer* @@ -569,16 +620,21 @@ ^:private compile-text-last-index "lastIndexOf" ) -(defn ^:private compile-text-size [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "()I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + + ^:private compile-text-size "java/lang/String" "length" + ^:private compile-text-hash "java/lang/Object" "hashCode" + ) (defn ^:private compile-text-replace-all [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?pattern (&/$Cons ?replacement (&/$Nil)))) ?values] @@ -596,6 +652,20 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replace" "(Ljava/lang/CharSequence;Ljava/lang/CharSequence;)Ljava/lang/String;"))]] (return nil))) +(defn ^:private compile-text-contains? [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?sub (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?sub) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "contains" "(Ljava/lang/CharSequence;)Z") + &&/wrap-boolean)]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] @@ -624,7 +694,7 @@ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "text_char" "(Ljava/lang/String;I)[Ljava/lang/Object;"))]] (return nil))) -(defn compile-io-log [compile ?values special-args] +(defn ^:private compile-io-log [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* @@ -636,7 +706,7 @@ (.visitLdcInsn &/unit-tag))]] (return nil))) -(defn compile-io-error [compile ?values special-args] +(defn ^:private compile-io-error [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* @@ -649,6 +719,79 @@ (.visitInsn Opcodes/ATHROW))]] (return nil))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Math" "D") + &&/wrap-double)]] + (return nil))) + + ^:private compile-math-e "E" + ^:private compile-math-pi "PI" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "(D)D") + &&/wrap-double)]] + (return nil))) + + ^:private compile-math-cos "cos" + ^:private compile-math-sin "sin" + ^:private compile-math-tan "tan" + ^:private compile-math-acos "acos" + ^:private compile-math-asin "asin" + ^:private compile-math-atan "atan" + ^:private compile-math-cosh "cosh" + ^:private compile-math-sinh "sinh" + ^:private compile-math-tanh "tanh" + ^:private compile-math-exp "exp" + ^:private compile-math-log "log" + ^:private compile-math-root2 "sqrt" + ^:private compile-math-root3 "cbrt" + ^:private compile-math-degrees "toDegrees" + ^:private compile-math-radians "toRadians" + ^:private compile-math-ceil "ceil" + ^:private compile-math-floor "floor" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double)] + _ (compile ?param) + :let [_ (doto *writer* + &&/unwrap-double)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "(DD)D") + &&/wrap-double)]] + (return nil))) + + ^:private compile-math-atan2 "atan2" + ^:private compile-math-pow "pow" + ) + +(defn ^:private compile-math-round [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "round" "(D)J") + (.visitInsn Opcodes/L2D) + &&/wrap-double)]] + (return nil))) + (defn compile-proc [compile proc-category proc-name ?values special-args] (case proc-category "lux" @@ -663,16 +806,19 @@ "text" (case proc-name "=" (compile-text-eq compile ?values special-args) + "<" (compile-text-lt compile ?values special-args) "append" (compile-text-append compile ?values special-args) "clip" (compile-text-clip compile ?values special-args) "index" (compile-text-index compile ?values special-args) "last-index" (compile-text-last-index compile ?values special-args) "size" (compile-text-size compile ?values special-args) + "hash" (compile-text-hash compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) + "char" (compile-text-char compile ?values special-args) "upper-case" (compile-text-upper-case compile ?values special-args) "lower-case" (compile-text-lower-case compile ?values special-args) - "char" (compile-text-char compile ?values special-args) + "contains?" (compile-text-contains? compile ?values special-args) ) "bit" @@ -767,9 +913,37 @@ "char" (case proc-name + "=" (compile-char-eq compile ?values special-args) + "<" (compile-char-lt compile ?values special-args) "to-nat" (compile-char-to-nat compile ?values special-args) "to-text" (compile-char-to-text compile ?values special-args) ) + + "math" + (case proc-name + "e" (compile-math-e compile ?values special-args) + "pi" (compile-math-pi compile ?values special-args) + "cos" (compile-math-cos compile ?values special-args) + "sin" (compile-math-sin compile ?values special-args) + "tan" (compile-math-tan compile ?values special-args) + "acos" (compile-math-acos compile ?values special-args) + "asin" (compile-math-asin compile ?values special-args) + "atan" (compile-math-atan compile ?values special-args) + "cosh" (compile-math-cosh compile ?values special-args) + "sinh" (compile-math-sinh compile ?values special-args) + "tanh" (compile-math-tanh compile ?values special-args) + "exp" (compile-math-exp compile ?values special-args) + "log" (compile-math-log compile ?values special-args) + "root2" (compile-math-root2 compile ?values special-args) + "root3" (compile-math-root3 compile ?values special-args) + "degrees" (compile-math-degrees compile ?values special-args) + "radians" (compile-math-radians compile ?values special-args) + "ceil" (compile-math-ceil compile ?values special-args) + "floor" (compile-math-floor compile ?values special-args) + "round" (compile-math-round compile ?values special-args) + "atan2" (compile-math-atan2 compile ?values special-args) + "pow" (compile-math-pow compile ?values special-args) + ) ;; else (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [proc-category proc-name])))) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index c6018398b..01064b829 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -2100,6 +2100,7 @@ (-> Char Text) (let' [as-text (_lux_case x #"\t" "\\t" + #"\v" "\\v" #"\b" "\\b" #"\n" "\\n" #"\r" "\\r" @@ -3222,13 +3223,14 @@ (#Some y) (#Some y)))) -(def: (last-index-of part text) - (-> Text Text (Maybe Nat)) - (_lux_proc ["text" "last-index"] [text part])) +(do-template [ ] + [(def: ( part text) + (-> Text Text (Maybe Nat)) + (_lux_proc ["text" ] [text part ]))] -(def: (index-of part text) - (-> Text Text (Maybe Nat)) - (_lux_proc ["text" "index"] [text part])) + [index-of "index" +0] + [last-index-of "last-index" (_lux_proc ["text" "size"] [text])] + ) (def: (clip1 from text) (-> Nat Text (Maybe Text)) @@ -3954,7 +3956,8 @@ [_ (#SymbolS "" m-name)] (do Monad [m-name (clean-module m-name)] - (wrap (list [m-name #None {#refer-defs #All #refer-open (list)}]))) + (wrap (list [m-name #None {#refer-defs #All + #refer-open (list)}]))) (^ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))]) (do Monad @@ -4863,6 +4866,7 @@ (-> Text Text) (let [escaped (|> original (replace "\t" "\\t") + (replace "\v" "\\v") (replace "\b" "\\b") (replace "\n" "\\n") (replace "\r" "\\r") diff --git a/stdlib/source/lux/data/char.lux b/stdlib/source/lux/data/char.lux index 28877ae34..0db90898e 100644 --- a/stdlib/source/lux/data/char.lux +++ b/stdlib/source/lux/data/char.lux @@ -9,48 +9,43 @@ ## [Structures] (struct: #export _ (Eq Char) (def: (= x y) - (_lux_proc ["jvm" "ceq"] [x y]))) + (_lux_proc ["char" "="] [x y]))) (struct: #export _ (Hash Char) (def: eq Eq) - (def: hash - (|>. [] - (_lux_proc ["jvm" "c2i"]) - [] - (_lux_proc ["jvm" "i2l"]) - int-to-nat))) + (def: (hash input) + (_lux_proc ["char" "to-nat"] [input]))) (struct: #export _ (ord;Ord Char) (def: eq Eq) - (do-template [ ] - [(def: ( test subject) - (_lux_proc ["jvm" ] [subject test]))] + (def: (< test subject) + (_lux_proc ["char" "<"] [subject test])) - [< "clt"] - [> "cgt"] - ) + (def: (<= test subject) + (or (_lux_proc ["char" "="] [subject test]) + (_lux_proc ["char" "<"] [subject test]))) - (do-template [ ] - [(def: ( test subject) - (or (_lux_proc ["jvm" "ceq"] [subject test]) - (_lux_proc ["jvm" ] [subject test])))] + (def: (> test subject) + (_lux_proc ["char" "<"] [test subject])) - [<= "clt"] - [>= "cgt"] - )) + (def: (>= test subject) + (or (_lux_proc ["char" "="] [test subject]) + (_lux_proc ["char" "<"] [test subject]))) + ) (struct: #export _ (Codec Text Char) (def: (encode x) (let [as-text (case x #"\t" "\\t" + #"\v" "\\v" #"\b" "\\b" #"\n" "\\n" #"\r" "\\r" #"\f" "\\f" #"\"" "\\\"" #"\\" "\\\\" - _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] + _ (_lux_proc ["char" "to-text"] [x]))] ($_ Text/append "#\"" as-text "\""))) (def: (decode y) @@ -70,13 +65,13 @@ [(#;Some #"\\") (#;Some char)] (case char #"t" (#;Right #"\t") + #"v" (#;Right #"\v") #"b" (#;Right #"\b") #"n" (#;Right #"\n") #"r" (#;Right #"\r") #"f" (#;Right #"\f") #"\"" (#;Right #"\"") #"\\" (#;Right #"\\") - #"t" (#;Right #"\t") _ (#;Left (Text/append "Wrong syntax for Char: " y))) _ @@ -84,14 +79,19 @@ (#;Left (Text/append "Wrong syntax for Char: " y)))))) ## [Values] -(def: #export (space? x) +(def: #export (space? char) {#;doc "Checks whether the character is white-space."} (-> Char Bool) - (_lux_proc ["jvm" "invokestatic:java.lang.Character:isWhitespace:char"] [x])) + (case char + (^or #"\t" #"\v" #" " #"\n" #"\r" #"\f") + true + + _ + false)) (def: #export (as-text x) (-> Char Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x])) + (_lux_proc ["char" "to-text"] [x])) (def: #export (char x) (-> Nat Char) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 0c52653af..1a29fc5b6 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -202,7 +202,8 @@ (let [digit (assume (_lux_proc ["text" "char"] [input idx]))] (case (_lux_proc ["text" "index"] [ - (_lux_proc ["char" "to-text"] [digit])]) + (_lux_proc ["char" "to-text"] [digit]) + +0]) #;None (#;Left ) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index bc350cc3a..4869d9e82 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -20,7 +20,7 @@ (def: #export (contains? sub text) (-> Text Text Bool) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:contains:java.lang.CharSequence"] [text sub])) + (_lux_proc ["text" "contains?"] [text sub])) (do-template [ ] [(def: #export ( input) @@ -33,13 +33,7 @@ (def: #export (clip from to input) (-> Nat Nat Text (Maybe Text)) - (if (and (n.< to from) - (n.<= (size input) to)) - (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] - [input - (_lux_proc ["jvm" "l2i"] [(nat-to-int from)]) - (_lux_proc ["jvm" "l2i"] [(nat-to-int to)])])) - #;None)) + (_lux_proc ["text" "clip"] [input from to])) (def: #export (clip' from input) (-> Nat Text (Maybe Text)) @@ -47,30 +41,24 @@ (def: #export (replace pattern value template) (-> Text Text Text Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value])) + (_lux_proc ["text" "replace-all"] [template pattern value])) -(do-template [ ] - [(def: #export ( pattern x) +(do-template [ ] + [(def: #export ( pattern input) (-> Text Text (Maybe Nat)) - (case (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" ] [x pattern])]) - -1 #;None - idx (#;Some (int-to-nat idx)))) + (_lux_proc ["text" ] [input pattern ])) - (def: #export ( pattern from x) + (def: #export ( pattern from input) (-> Text Nat Text (Maybe Nat)) - (if (n.< (size x) from) - (case (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" ] [x pattern (_lux_proc ["jvm" "l2i"] [(nat-to-int from)])])]) - -1 #;None - idx (#;Some (int-to-nat idx))) - #;None))] - - [index-of "invokevirtual:java.lang.String:indexOf:java.lang.String" index-of' "invokevirtual:java.lang.String:indexOf:java.lang.String,int"] - [last-index-of "invokevirtual:java.lang.String:lastIndexOf:java.lang.String" last-index-of' "invokevirtual:java.lang.String:lastIndexOf:java.lang.String,int"] + (_lux_proc ["text" ] [input pattern from]))] + + [index-of index-of' "index" +0] + [last-index-of last-index-of' "last-index" (size input)] ) (def: #export (starts-with? prefix x) (-> Text Text Bool) - (case (index-of prefix x) + (case (index-of' prefix x) (#;Some +0) true @@ -79,7 +67,7 @@ (def: #export (ends-with? postfix x) (-> Text Text Bool) - (case (last-index-of postfix x) + (case (last-index-of' postfix x) (#;Some n) (n.= (size x) (n.+ (size postfix) n)) @@ -89,16 +77,17 @@ (def: #export (split at x) (-> Nat Text (Maybe [Text Text])) - (if (n.<= (size x) at) - (let [pre (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [x (_lux_proc ["jvm" "l2i"] [0]) (_lux_proc ["jvm" "l2i"] [(nat-to-int at)])]) - post (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int at)])])] - (#;Some [pre post])) + (case [(clip +0 at x) (clip' at x)] + [(#;Some pre) (#;Some post)] + (#;Some [pre post]) + + _ #;None)) (def: #export (split-with token sample) (-> Text Text (Maybe [Text Text])) (do Monad - [index (index-of token sample) + [index (index-of' token sample) [pre post'] (split index sample) [_ post] (split (size token) post')] (wrap [pre post]))) @@ -123,20 +112,25 @@ (struct: #export _ (ord;Ord Text) (def: eq Eq) - (do-template [ ] - [(def: ( test subject) - ( 0 - (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:compareTo:java.lang.String"] [subject test])])))] + (def: (< test subject) + (_lux_proc ["text" "<"] [subject test])) + + (def: (<= test subject) + (or (_lux_proc ["text" "<"] [subject test]) + (_lux_proc ["text" "="] [subject test]))) - [< i.<] - [<= i.<=] - [> i.>] - [>= i.>=])) + (def: (> test subject) + (_lux_proc ["text" "<"] [test subject])) + + (def: (>= test subject) + (or (_lux_proc ["text" "<"] [test subject]) + (_lux_proc ["text" "="] [test subject]))) + ) (struct: #export _ (Monoid Text) (def: unit "") - (def: (append x y) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y]))) + (def: (append left right) + (_lux_proc ["text" "append"] [left right]))) (open Monoid) @@ -145,6 +139,7 @@ (let [escaped (|> original (replace "\\" "\\\\") (replace "\t" "\\t") + (replace "\v" "\\v") (replace "\b" "\\b") (replace "\n" "\\n") (replace "\r" "\\r") @@ -161,6 +156,7 @@ (|> input' (replace "\\\\" "\\") (replace "\\t" "\t") + (replace "\\v" "\v") (replace "\\b" "\b") (replace "\\n" "\n") (replace "\\r" "\r") @@ -175,12 +171,8 @@ (struct: #export _ (Hash Text) (def: eq Eq) - (def: hash - (|>. [] - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:hashCode:"]) - [] - (_lux_proc ["jvm" "i2l"]) - int-to-nat))) + (def: (hash input) + (_lux_proc ["text" "hash"] [input]))) (def: #export concat (-> (List Text) Text) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index e87bb1b1b..6f41b3e9b 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -5,7 +5,6 @@ [number "Int/" Number] [product] text/format) - host [compiler] (macro ["s" syntax #+ syntax: Syntax "s/" Functor] [ast]))) @@ -14,10 +13,10 @@ (do-template [ ] [(def: #export Real - (_lux_proc ["jvm" ] []))] + (_lux_proc ["math" ] []))] - [e "getstatic:java.lang.Math:E"] - [pi "getstatic:java.lang.Math:PI"] + [e "e"] + [pi "pi"] ) (def: #export tau @@ -26,52 +25,43 @@ 6.28318530717958647692) (do-template [ ] - [(def: #export ( n) + [(def: #export ( input) (-> Real Real) - (_lux_proc ["jvm" ] [n]))] + (_lux_proc ["math" ] [input]))] - [cos "invokestatic:java.lang.Math:cos:double"] - [sin "invokestatic:java.lang.Math:sin:double"] - [tan "invokestatic:java.lang.Math:tan:double"] + [cos "cos"] + [sin "sin"] + [tan "tan"] - [acos "invokestatic:java.lang.Math:acos:double"] - [asin "invokestatic:java.lang.Math:asin:double"] - [atan "invokestatic:java.lang.Math:atan:double"] + [acos "acos"] + [asin "asin"] + [atan "atan"] - [cosh "invokestatic:java.lang.Math:cosh:double"] - [sinh "invokestatic:java.lang.Math:sinh:double"] - [tanh "invokestatic:java.lang.Math:tanh:double"] + [cosh "cosh"] + [sinh "sinh"] + [tanh "tanh"] - [exp "invokestatic:java.lang.Math:exp:double"] - [log "invokestatic:java.lang.Math:log:double"] + [exp "exp"] + [log "log"] - [root2 "invokestatic:java.lang.Math:sqrt:double"] - [root3 "invokestatic:java.lang.Math:cbrt:double"] + [root2 "root2"] + [root3 "root3"] - [degrees "invokestatic:java.lang.Math:toDegrees:double"] - [radians "invokestatic:java.lang.Math:toRadians:double"] - ) + [degrees "degrees"] + [radians "radians"] -(do-template [ ] - [(def: #export ( n) - (-> Real Real) - (_lux_proc ["jvm" ] [n]))] - - [ceil "invokestatic:java.lang.Math:ceil:double"] - [floor "invokestatic:java.lang.Math:floor:double"] + [ceil "ceil"] + [floor "floor"] + [round "round"] ) -(def: #export (round n) - (-> Real Real) - (int-to-real (_lux_proc ["jvm" "invokestatic:java.lang.Math:round:double"] [n]))) - (do-template [ ] [(def: #export ( param subject) (-> Real Real Real) - (_lux_proc ["jvm" ] [subject param]))] + (_lux_proc ["math" ] [subject param]))] - [atan2 "invokestatic:java.lang.Math:atan2:double,double"] - [pow "invokestatic:java.lang.Math:pow:double,double"] + [atan2 "atan2"] + [pow "pow"] ) (def: #export (log' base input) diff --git a/stdlib/test/test/lux/data/text.lux b/stdlib/test/test/lux/data/text.lux index 8ddd27a7c..883ff0b2b 100644 --- a/stdlib/test/test/lux/data/text.lux +++ b/stdlib/test/test/lux/data/text.lux @@ -32,10 +32,10 @@ (&;nth idx) (case> (^=> (#;Some char) [(char;as-text char) char'] - [[(&;index-of char' sample) - (&;last-index-of char' sample) - (&;index-of' char' idx sample) - (&;last-index-of' char' idx sample)] + [[(&;index-of' char' sample) + (&;last-index-of' char' sample) + (&;index-of char' idx sample) + (&;last-index-of char' idx sample)] [(#;Some io) (#;Some lio) (#;Some io') (#;Some lio')]]) (and (n.<= idx io) -- cgit v1.3.1 From d8bba8c477525a0e70eab4f289e043cfe352bd62 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Feb 2017 14:48:52 -0400 Subject: - Implemented math procedures for JS. - Degree<->radian conversions are no longer math procedures. --- luxc/src/lux/analyser/proc/common.clj | 4 -- luxc/src/lux/compiler/js/proc/common.clj | 68 +++++++++++++++++++++++++++++++ luxc/src/lux/compiler/jvm/proc/common.clj | 4 -- stdlib/source/lux/math.lux | 3 -- stdlib/test/test/lux/math.lux | 3 -- 5 files changed, 68 insertions(+), 14 deletions(-) (limited to 'stdlib/test') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index c91074676..050877ed5 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -391,8 +391,6 @@ ^:private analyse-math-log "log" ^:private analyse-math-root2 "root2" ^:private analyse-math-root3 "root3" - ^:private analyse-math-degrees "degrees" - ^:private analyse-math-radians "radians" ^:private analyse-math-ceil "ceil" ^:private analyse-math-floor "floor" ^:private analyse-math-round "round" @@ -615,8 +613,6 @@ "log" (analyse-math-log analyse exo-type ?values) "root2" (analyse-math-root2 analyse exo-type ?values) "root3" (analyse-math-root3 analyse exo-type ?values) - "degrees" (analyse-math-degrees analyse exo-type ?values) - "radians" (analyse-math-radians analyse exo-type ?values) "ceil" (analyse-math-ceil analyse exo-type ?values) "floor" (analyse-math-floor analyse exo-type ?values) "round" (analyse-math-round analyse exo-type ?values) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 60ade9300..942f24c79 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -439,6 +439,50 @@ (str "LuxRT.toNumberI64(" =milliseconds ")") ")")))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Nil) ?values]] + (return (str "Math." )))) + + ^:private compile-math-e "E" + ^:private compile-math-pi "PI" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + =input (compile ?input)] + (return (str "Math." "(" =input ")")))) + + ^:private compile-math-cos "cos" + ^:private compile-math-sin "sin" + ^:private compile-math-tan "tan" + ^:private compile-math-acos "acos" + ^:private compile-math-asin "asin" + ^:private compile-math-atan "atan" + ^:private compile-math-cosh "cosh" + ^:private compile-math-sinh "sinh" + ^:private compile-math-tanh "tanh" + ^:private compile-math-exp "exp" + ^:private compile-math-log "log" + ^:private compile-math-root2 "sqrt" + ^:private compile-math-root3 "cbrt" + ^:private compile-math-ceil "ceil" + ^:private compile-math-floor "floor" + ^:private compile-math-round "round" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + =input (compile ?input) + =param (compile ?param)] + (return (str "Math." "(" =input "," =param ")")))) + + ^:private compile-math-atan2 "atan2" + ^:private compile-math-pow "pow" + ) + (defn compile-proc [compile category proc ?values special-args] (case category "lux" @@ -566,6 +610,30 @@ "to-nat" (compile-char-to-nat compile ?values special-args) ) + "math" + (case proc + "e" (compile-math-e compile ?values special-args) + "pi" (compile-math-pi compile ?values special-args) + "cos" (compile-math-cos compile ?values special-args) + "sin" (compile-math-sin compile ?values special-args) + "tan" (compile-math-tan compile ?values special-args) + "acos" (compile-math-acos compile ?values special-args) + "asin" (compile-math-asin compile ?values special-args) + "atan" (compile-math-atan compile ?values special-args) + "cosh" (compile-math-cosh compile ?values special-args) + "sinh" (compile-math-sinh compile ?values special-args) + "tanh" (compile-math-tanh compile ?values special-args) + "exp" (compile-math-exp compile ?values special-args) + "log" (compile-math-log compile ?values special-args) + "root2" (compile-math-root2 compile ?values special-args) + "root3" (compile-math-root3 compile ?values special-args) + "ceil" (compile-math-ceil compile ?values special-args) + "floor" (compile-math-floor compile ?values special-args) + "round" (compile-math-round compile ?values special-args) + "atan2" (compile-math-atan2 compile ?values special-args) + "pow" (compile-math-pow compile ?values special-args) + ) + "atom" (case proc "new" (compile-atom-new compile ?values special-args) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 6a952e6d3..b7e80dd2e 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -774,8 +774,6 @@ ^:private compile-math-log "log" ^:private compile-math-root2 "sqrt" ^:private compile-math-root3 "cbrt" - ^:private compile-math-degrees "toDegrees" - ^:private compile-math-radians "toRadians" ^:private compile-math-ceil "ceil" ^:private compile-math-floor "floor" ) @@ -1023,8 +1021,6 @@ "log" (compile-math-log compile ?values special-args) "root2" (compile-math-root2 compile ?values special-args) "root3" (compile-math-root3 compile ?values special-args) - "degrees" (compile-math-degrees compile ?values special-args) - "radians" (compile-math-radians compile ?values special-args) "ceil" (compile-math-ceil compile ?values special-args) "floor" (compile-math-floor compile ?values special-args) "round" (compile-math-round compile ?values special-args) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index 6f41b3e9b..c49e82969 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -47,9 +47,6 @@ [root2 "root2"] [root3 "root3"] - [degrees "degrees"] - [radians "radians"] - [ceil "ceil"] [floor "floor"] [round "round"] diff --git a/stdlib/test/test/lux/math.lux b/stdlib/test/test/lux/math.lux index 18cb1545c..769a6f889 100644 --- a/stdlib/test/test/lux/math.lux +++ b/stdlib/test/test/lux/math.lux @@ -35,9 +35,6 @@ ## (assert "Tangent and arc-tangent are inverse functions." ## (|> angle &;tan &;atan (within? margin angle))) - -## (assert "Can freely go between degrees and radians." -## (|> angle &;degrees &;radians (within? margin angle))) ## )) (test: "Roots" -- cgit v1.3.1 From 79c10caf4c7e370dc53c4c60c57cc16ccec48773 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Feb 2017 19:36:21 -0400 Subject: - Added a new try-catch procedure. --- luxc/src/lux/analyser/proc/common.clj | 15 ++++++++++++++- luxc/src/lux/compiler/jvm/proc/common.clj | 12 +++++++++++- luxc/src/lux/compiler/jvm/rt.clj | 23 +++++++++++++++++++++++ stdlib/source/lux/test.lux | 5 ++--- stdlib/test/test/lux/data/char.lux | 3 +-- 5 files changed, 51 insertions(+), 7 deletions(-) (limited to 'stdlib/test') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 050877ed5..9a295b1eb 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -17,6 +17,18 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["lux" "is"]) (&/|list =left =right) (&/|list))))))))) +(defn ^:private analyse-lux-try [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons op (&/$Nil)) ?values] + =op (&&/analyse-1 analyse (&/$AppT &type/IO $var) op) + _ (&type/check exo-type (&/$SumT &type/Text ;; lux;Left + $var ;; lux;Right + )) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["lux" "try"]) (&/|list =op) (&/|list))))))))) + (do-template [ ] (defn [analyse exo-type ?values] (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] @@ -470,7 +482,8 @@ (case category "lux" (case proc - "is" (analyse-lux-is analyse exo-type ?values)) + "is" (analyse-lux-is analyse exo-type ?values) + "try" (analyse-lux-try analyse exo-type ?values)) "io" (case proc diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index b7e80dd2e..d434e0365 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -179,6 +179,15 @@ (.visitLabel $end))]] (return nil))) +(defn ^:private compile-lux-try [compile ?values special-args] + (|do [:let [(&/$Cons ?op (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?op) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "lux/Function") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "runTry" "(Llux/Function;)[Ljava/lang/Object;"))]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -878,7 +887,8 @@ (case category "lux" (case proc - "is" (compile-lux-is compile ?values special-args)) + "is" (compile-lux-is compile ?values special-args) + "try" (compile-lux-try compile ?values special-args)) "io" (case proc diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj index 0f86325f2..97c7d849c 100644 --- a/luxc/src/lux/compiler/jvm/rt.clj +++ b/luxc/src/lux/compiler/jvm/rt.clj @@ -1440,6 +1440,29 @@ (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd)) + _ (let [$from (new Label) + $to (new Label) + $handler (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "runTry" "(Llux/Function;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/Throwable") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ACONST_NULL) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "lux/Function" &&/apply-method (&&/apply-signature 1)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) ;; T + (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; TI + (.visitInsn Opcodes/ACONST_NULL) ;; TI? + swap2x1 ;; I?T + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "toString" "()Ljava/lang/String;") ;; I?S + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) _ (doto =class (compile-LuxRT-pm-methods) (compile-LuxRT-adt-methods) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index bab513cc4..d953b7d65 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -13,8 +13,7 @@ text/format [error #- fail "Error/" Monad]) [io #- run] - ["R" random] - [host #- try])) + ["R" random])) ## [Host] (def: now @@ -156,7 +155,7 @@ (def: #hidden (try-body lazy-body) (-> (IO Test) Test) - (case (host;try (io;run lazy-body)) + (case (_lux_proc ["lux" "try"] [lazy-body]) (#;Right output) output diff --git a/stdlib/test/test/lux/data/char.lux b/stdlib/test/test/lux/data/char.lux index 67332f282..88a5d86ae 100644 --- a/stdlib/test/test/lux/data/char.lux +++ b/stdlib/test/test/lux/data/char.lux @@ -6,8 +6,7 @@ [text] text/format) ["R" random] - pipe - [host #- try]) + pipe) lux/test) (test: "Char operations" -- cgit v1.3.1 From 6f554dc5a4172cd2afd7bde30b5edcaf0266f63d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Mar 2017 00:04:09 -0400 Subject: - Implemented custom JS host procedures. --- luxc/src/lux/analyser.clj | 6 +- luxc/src/lux/analyser/proc/js.clj | 93 ++ luxc/src/lux/compiler/js.clj | 5 +- luxc/src/lux/compiler/js/proc/host.clj | 86 ++ luxc/src/lux/compiler/js/rt.clj | 17 +- luxc/src/lux/compiler/jvm/proc/host.clj | 1 - stdlib/source/lux/host.js.lux | 83 ++ stdlib/source/lux/host.jvm.lux | 2169 +++++++++++++++++++++++++++++++ stdlib/source/lux/host.lux | 2169 ------------------------------- stdlib/test/test/lux/host.js.lux | 32 + stdlib/test/test/lux/host.jvm.lux | 121 ++ stdlib/test/test/lux/host.lux | 121 -- 12 files changed, 2607 insertions(+), 2296 deletions(-) create mode 100644 luxc/src/lux/analyser/proc/js.clj create mode 100644 luxc/src/lux/compiler/js/proc/host.clj create mode 100644 stdlib/source/lux/host.js.lux create mode 100644 stdlib/source/lux/host.jvm.lux delete mode 100644 stdlib/source/lux/host.lux create mode 100644 stdlib/test/test/lux/host.js.lux create mode 100644 stdlib/test/test/lux/host.jvm.lux delete mode 100644 stdlib/test/test/lux/host.lux (limited to 'stdlib/test') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index 5f35d3c25..aaf441713 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -12,7 +12,8 @@ [module :as &&module] [parser :as &&a-parser]) (lux.analyser.proc [common :as &&common] - [jvm :as &&jvm]))) + [jvm :as &&jvm] + [js :as &&js]))) ;; [Utils] (defn analyse-variant+ [analyse exo-type ident values] @@ -136,7 +137,8 @@ (case ?category "jvm" (|do [_ &/jvm-host] (&&jvm/analyse-host analyse exo-type compilers ?proc ?args)) - ;; "js" + "js" (|do [_ &/js-host] + (&&js/analyse-host analyse exo-type ?proc ?args)) ;; common (&&common/analyse-proc analyse exo-type ?category ?proc ?args)) )) diff --git a/luxc/src/lux/analyser/proc/js.clj b/luxc/src/lux/analyser/proc/js.clj new file mode 100644 index 000000000..2d36dd0d9 --- /dev/null +++ b/luxc/src/lux/analyser/proc/js.clj @@ -0,0 +1,93 @@ +(ns lux.analyser.proc.js + (:require (clojure [template :refer [do-template]] + [string :as string]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type]) + (lux.analyser [base :as &&]))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?function ?args) ?values] + =function (&&/analyse-1 analyse (&/$HostT "function" &/$Nil) ?function) + =args (&/map% (partial &&/analyse-1+ analyse) ?args) + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" ]) (&/$Cons =function =args) (&/|list))))))) + + ^:private analyse-js-new "new" + ^:private analyse-js-call "call" + ) + +(defn ^:private analyse-js-object-call [analyse exo-type ?values] + (|do [:let [(&/$Cons ?object (&/$Cons ?field ?args)) ?values] + =object (&&/analyse-1 analyse (&/$HostT "object" &/$Nil) ?object) + =field (&&/analyse-1 analyse &type/Text ?field) + =args (&/map% (partial &&/analyse-1+ analyse) ?args) + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" "object-call"]) (&/$Cons =object (&/$Cons =field =args)) (&/|list))))))) + +(defn ^:private analyse-js-ref [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS ?ref-name)] (&/$Nil)) ?values] + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" "ref"]) (&/|list) (&/|list ?ref-name))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values] + =object (&&/analyse-1 analyse (&/$HostT "object" &/$Nil) ?object) + =field (&&/analyse-1 analyse &type/Text ?field) + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" ]) (&/|list =object =field) (&/|list))))))) + + ^:private analyse-js-get-field "get-field" + ^:private analyse-js-delete-field "delete-field" + ) + +(defn ^:private analyse-js-set-field [analyse exo-type ?values] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Cons ?value (&/$Nil)))) ?values] + =object (&&/analyse-1 analyse (&/$HostT "object" &/$Nil) ?object) + =field (&&/analyse-1 analyse &type/Text ?field) + =value (&&/analyse-1+ analyse ?value) + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" "set-field"]) (&/|list =object =field =value) (&/|list))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + :let [output-type (&/$HostT &/$Nil)] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" ]) (&/|list) (&/|list))))))) + + ^:private analyse-js-object "object" "object" + ^:private analyse-js-null "null" "object" + ^:private analyse-js-undefined "undefined" "undefined" + ) + +(defn analyse-host [analyse exo-type proc ?values] + (case proc + "new" (analyse-js-new analyse exo-type ?values) + "call" (analyse-js-call analyse exo-type ?values) + "object-call" (analyse-js-object-call analyse exo-type ?values) + "ref" (analyse-js-ref analyse exo-type ?values) + "object" (analyse-js-object analyse exo-type ?values) + "get-field" (analyse-js-get-field analyse exo-type ?values) + "set-field" (analyse-js-set-field analyse exo-type ?values) + "delete-field" (analyse-js-delete-field analyse exo-type ?values) + "null" (analyse-js-null analyse exo-type ?values) + "undefined" (analyse-js-undefined analyse exo-type ?values) + ;; else + (&/fail-with-loc (str "[Analyser Error] Unknown JS procedure: " proc))) + ) diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 4f0546bf0..1537bb7de 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -23,7 +23,8 @@ [lux :as &&lux] [rt :as &&rt] [cache :as &&js-cache]) - (lux.compiler.js.proc [common :as &&common]) + (lux.compiler.js.proc [common :as &&common] + [host :as &&host]) ) (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory NashornScriptEngine @@ -100,7 +101,7 @@ (&o/$proc [?proc-category ?proc-name] ?args special-args) (case ?proc-category - ;; "js" ... + "js" (&&host/compile-proc compile-expression ?proc-name ?args special-args) ;; common (&&common/compile-proc compile-expression ?proc-category ?proc-name ?args special-args)) diff --git a/luxc/src/lux/compiler/js/proc/host.clj b/luxc/src/lux/compiler/js/proc/host.clj new file mode 100644 index 000000000..3c0392a6b --- /dev/null +++ b/luxc/src/lux/compiler/js/proc/host.clj @@ -0,0 +1,86 @@ +(ns lux.compiler.js.proc.host + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]]))) + +(defn ^:private compile-js-ref [compile ?values special-args] + (|do [:let [(&/$Cons ?name (&/$Nil)) special-args]] + (return ?name))) + +(defn ^:private compile-js-new [compile ?values special-args] + (|do [:let [(&/$Cons ?function ?args) ?values] + =function (compile ?function) + =args (&/map% compile ?args)] + (return (str "new (" =function ")(" + (->> =args + (&/|interpose ",") + (&/fold str "")) + ")")))) + +(defn ^:private compile-js-call [compile ?values special-args] + (|do [:let [(&/$Cons ?function ?args) ?values] + =function (compile ?function) + =args (&/map% compile ?args)] + (return (str "(" =function ")(" + (->> =args + (&/|interpose ",") + (&/fold str "")) + ")")))) + +(defn ^:private compile-js-object-call [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?field ?args)) ?values] + =object (compile ?object) + =field (compile ?field) + =args (&/map% compile ?args)] + (return (str "LuxRT." "jsObjectCall" + "(" =object + "," =field + "," (str "[" (->> =args (&/|interpose ",") (&/fold str "")) "]") + ")")))) + +(defn ^:private compile-js-object [compile ?values special-args] + (|do [:let [(&/$Nil) ?values]] + (return "{}"))) + +(defn ^:private compile-js-get-field [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values] + =object (compile ?object) + =field (compile ?field)] + (return (str "(" =object ")" "[" =field "]")))) + +(defn ^:private compile-js-set-field [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Cons ?input (&/$Nil)))) ?values] + =object (compile ?object) + =field (compile ?field) + =input (compile ?input)] + (return (str "LuxRT." "jsSetField" "(" =object "," =field "," =input ")")))) + +(defn ^:private compile-js-delete-field [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values] + =object (compile ?object) + =field (compile ?field)] + (return (str "LuxRT." "jsDeleteField" "(" =object "," =field ")")))) + +(do-template [ ] + (defn [compile ?values special-args] + (return )) + + ^:private compile-js-null "null" + ^:private compile-js-undefined "undefined" + ) + +(defn compile-proc [compile proc-name ?values special-args] + (case proc-name + "new" (compile-js-new compile ?values special-args) + "call" (compile-js-call compile ?values special-args) + "object-call" (compile-js-object-call compile ?values special-args) + "ref" (compile-js-ref compile ?values special-args) + "object" (compile-js-object compile ?values special-args) + "get-field" (compile-js-get-field compile ?values special-args) + "set-field" (compile-js-set-field compile ?values special-args) + "delete-field" (compile-js-delete-field compile ?values special-args) + "null" (compile-js-null compile ?values special-args) + "undefined" (compile-js-undefined compile ?values special-args) + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " ["js" proc-name])))) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index c2b3cba01..cdd83883d 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -755,6 +755,20 @@ "})") }) +(def ^:private js-methods + {"jsSetField" (str "(function jsSetField(object, field, input) {" + "object[field] = input;" + "return object;" + "})") + "jsDeleteField" (str "(function jsDeleteField(object, field) {" + "delete object[field];" + "return object;" + "})") + "jsObjectCall" (str "(function jsObjectCall(object, method, args) {" + "return object[method].apply(object, args);" + "})") + }) + (def LuxRT "LuxRT") (def compile-LuxRT @@ -766,7 +780,8 @@ text-methods array-methods bit-methods - io-methods) + io-methods + js-methods) (map (fn [[key val]] (str key ":" val))) (interpose ",") diff --git a/luxc/src/lux/compiler/jvm/proc/host.clj b/luxc/src/lux/compiler/jvm/proc/host.clj index 0e299f123..365a26937 100644 --- a/luxc/src/lux/compiler/jvm/proc/host.clj +++ b/luxc/src/lux/compiler/jvm/proc/host.clj @@ -1042,7 +1042,6 @@ (return nil))) (defn compile-proc [compile proc-name ?values special-args] - "jvm" (case proc-name "synchronized" (compile-jvm-synchronized compile ?values special-args) "load-class" (compile-jvm-load-class compile ?values special-args) diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux new file mode 100644 index 000000000..f935dc8d6 --- /dev/null +++ b/stdlib/source/lux/host.js.lux @@ -0,0 +1,83 @@ +(;module: + lux + (lux (control monad) + (data (coll [list #* "L/" Fold])) + [compiler #+ with-gensyms] + (macro [ast] + ["s" syntax #+ syntax: Syntax]) + )) + +(do-template [ ] + [(type: #export (#;HostT #;Nil))] + + [Object "object"] + [Function "function"] + [Symbol "symbol"] + [Undefined "undefined"] + ) + +(do-template [ ] + [(type: #export )] + + [String Text] + [Number Real] + [Boolean Bool] + ) + +## [Syntax] +(syntax: #export (set! field-name field-value object) + {#;doc (doc "A way to set fields from objects." + (set! "foo" 1234 some-object))} + (wrap (list (` (;_lux_proc ["js" "set-field"] [(~ object) (~ field-name) (~ field-value)]))))) + +(syntax: #export (delete! field-name object) + {#;doc (doc "A way to delete fields from objects." + (delete! "foo" some-object))} + (wrap (list (` (;_lux_proc ["js" "delete-field"] [(~ object) (~ field-name)]))))) + +(syntax: #export (get field-name type object) + {#;doc (doc "A way to get fields from objects." + (get "ceil" (ref "Math")) + (get "ceil" (-> Real Real) (ref "Math")))} + (wrap (list (` (:! (~ type) + (;_lux_proc ["js" "get-field"] [(~ object) (~ field-name)])))))) + +(syntax: #export (object [kvs (s;some (s;seq s;any s;any))]) + {#;doc (doc "A way to create JavaScript objects." + (object) + (object "foo" foo "bar" (inc bar)))} + (wrap (list (L/fold (lambda [[k v] object] + (` (set! (~ k) (~ v) (~ object)))) + (` (;_lux_proc ["js" "object"] [])) + kvs)))) + +(syntax: #export (ref [name s;text] [type (s;opt s;any)]) + {#;doc (doc "A way to refer to JavaScript variables." + (ref "document") + (ref "Math.ceil" (-> Real Real)))} + (wrap (list (` (:! (~ (default (' ;;Object) type)) + (;_lux_proc ["js" "ref"] [(~ (ast;text name))])))))) + +(do-template [ ] + [(syntax: #export () + {#;doc (doc + ())} + (wrap (list (` (;_lux_proc ["js" ] [])))))] + + [null "null" "Null object reference."] + [undef "undefined" "Undefined."] + ) + +(syntax: #export (call! [shape (s;alt ($_ s;seq s;any (s;tuple (s;some s;any)) (s;opt s;any)) + ($_ s;seq s;any s;text (s;tuple (s;some s;any)) (s;opt s;any)))]) + {#;doc (doc "A way to call JavaScript functions and methods." + (call! (ref "Math.ceil") [123.45]) + (call! (ref "Math") "ceil" [123.45]))} + (case shape + (#;Left [function args ?type]) + (wrap (list (` (:! (~ (default (' ;;Object) ?type)) + (;_lux_proc ["js" "call"] [(~ function) (~@ args)]))))) + + (#;Right [object field args ?type]) + (wrap (list (` (:! (~ (default (' ;;Object) ?type)) + (;_lux_proc ["js" "object-call"] [(~ object) (~ (ast;text field)) (~@ args)]))))))) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux new file mode 100644 index 000000000..41d567165 --- /dev/null +++ b/stdlib/source/lux/host.jvm.lux @@ -0,0 +1,2169 @@ +(;module: + lux + (lux (control monad + [enum]) + [io #+ IO Monad io] + (codata function) + (data (coll [list #* "" Functor Fold "List/" Monad Monoid] + [array #+ Array]) + number + maybe + [product] + [text "Text/" Eq Monoid] + text/format + [bool "Bool/" Codec]) + [compiler #+ with-gensyms Functor Monad] + (macro [ast] + ["s" syntax #+ syntax: Syntax]) + [type] + )) + +(do-template [ ] + [(def: #export ( value) + {#;doc (doc "Type converter." + "From:" + + "To:" + )} + (-> (host ) (host )) + (_lux_proc ["jvm" ] [value]))] + + [b2l "b2l" java.lang.Byte java.lang.Long] + + [s2l "s2l" java.lang.Short java.lang.Long] + + [d2i "d2i" java.lang.Double java.lang.Integer] + [d2l "d2l" java.lang.Double java.lang.Long] + [d2f "d2f" java.lang.Double java.lang.Float] + + [f2i "f2i" java.lang.Float java.lang.Integer] + [f2l "f2l" java.lang.Float java.lang.Long] + [f2d "f2d" java.lang.Float java.lang.Double] + + [i2b "i2b" java.lang.Integer java.lang.Byte] + [i2s "i2s" java.lang.Integer java.lang.Short] + [i2l "i2l" java.lang.Integer java.lang.Long] + [i2f "i2f" java.lang.Integer java.lang.Float] + [i2d "i2d" java.lang.Integer java.lang.Double] + [i2c "i2c" java.lang.Integer java.lang.Character] + + [l2b "l2b" java.lang.Long java.lang.Byte] + [l2s "l2s" java.lang.Long java.lang.Short] + [l2i "l2i" java.lang.Long java.lang.Integer] + [l2f "l2f" java.lang.Long java.lang.Float] + [l2d "l2d" java.lang.Long java.lang.Double] + + [c2b "c2b" java.lang.Character java.lang.Byte] + [c2s "c2s" java.lang.Character java.lang.Short] + [c2i "c2i" java.lang.Character java.lang.Integer] + [c2l "c2l" java.lang.Character java.lang.Long] + ) + +## [Utils] +(def: array-type-name "#Array") +(def: constructor-method-name "") +(def: member-separator ".") + +## Types +(do-template [ ] + [(type: #export + (#;HostT #;Nil))] + + ["[Z" Boolean-Array] + ["[B" Byte-Array] + ["[S" Short-Array] + ["[I" Int-Array] + ["[J" Long-Array] + ["[F" Float-Array] + ["[D" Double-Array] + ["[C" Char-Array] + ) + +(type: Code Text) + +(type: BoundKind + #UpperBound + #LowerBound) + +(type: #rec GenericType + (#GenericTypeVar Text) + (#GenericClass [Text (List GenericType)]) + (#GenericArray GenericType) + (#GenericWildcard (Maybe [BoundKind GenericType]))) + +(type: TypeParam + [Text (List GenericType)]) + +(type: Primitive-Mode + #ManualPrM + #AutoPrM) + +(type: PrivacyModifier + #PublicPM + #PrivatePM + #ProtectedPM + #DefaultPM) + +(type: StateModifier + #VolatileSM + #FinalSM + #DefaultSM) + +(type: InheritanceModifier + #FinalIM + #AbstractIM + #DefaultIM) + +(type: ClassKind + #Class + #Interface) + +(type: ClassDecl + {#class-name Text + #class-params (List TypeParam)}) + +(type: StackFrame (host java.lang.StackTraceElement)) +(type: StackTrace (Array StackFrame)) + +(type: SuperClassDecl + {#super-class-name Text + #super-class-params (List GenericType)}) + +(type: AnnotationParam + [Text AST]) + +(type: Annotation + {#ann-name Text + #ann-params (List AnnotationParam)}) + +(type: MemberDecl + {#member-name Text + #member-privacy PrivacyModifier + #member-anns (List Annotation)}) + +(type: FieldDecl + (#ConstantField GenericType AST) + (#VariableField StateModifier GenericType)) + +(type: MethodDecl + {#method-tvars (List TypeParam) + #method-inputs (List GenericType) + #method-output GenericType + #method-exs (List GenericType)}) + +(type: ArgDecl + {#arg-name Text + #arg-type GenericType}) + +(type: ConstructorArg + [GenericType AST]) + +(type: MethodDef + (#ConstructorMethod [Bool + (List TypeParam) + (List ArgDecl) + (List ConstructorArg) + AST + (List GenericType)]) + (#VirtualMethod [Bool + Bool + (List TypeParam) + (List ArgDecl) + GenericType + AST + (List GenericType)]) + (#OverridenMethod [Bool + ClassDecl + (List TypeParam) + (List ArgDecl) + GenericType + AST + (List GenericType)]) + (#StaticMethod [Bool + (List TypeParam) + (List ArgDecl) + GenericType + AST + (List GenericType)]) + (#AbstractMethod [(List TypeParam) + (List ArgDecl) + GenericType + (List GenericType)]) + (#NativeMethod [(List TypeParam) + (List ArgDecl) + GenericType + (List GenericType)])) + +(type: PartialCall + {#pc-method AST + #pc-args AST}) + +(type: ImportMethodKind + #StaticIMK + #VirtualIMK) + +(type: ImportMethodCommons + {#import-member-mode Primitive-Mode + #import-member-alias Text + #import-member-kind ImportMethodKind + #import-member-tvars (List TypeParam) + #import-member-args (List [Bool GenericType]) + #import-member-maybe? Bool + #import-member-try? Bool + #import-member-io? Bool}) + +(type: ImportConstructorDecl + {}) + +(type: ImportMethodDecl + {#import-method-name Text + #import-method-return GenericType}) + +(type: ImportFieldDecl + {#import-field-mode Primitive-Mode + #import-field-name Text + #import-field-static? Bool + #import-field-maybe? Bool + #import-field-setter? Bool + #import-field-type GenericType}) + +(type: ImportMemberDecl + (#EnumDecl (List Text)) + (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) + (#MethodDecl [ImportMethodCommons ImportMethodDecl]) + (#FieldAccessDecl ImportFieldDecl)) + +(type: ClassImports + (List [Text Text])) + +## Utils +(def: (short-class-name name) + (-> Text Text) + (case (reverse (text;split-all-with "." name)) + (#;Cons short-name _) + short-name + + #;Nil + name)) + +(def: (manual-primitive-to-type class) + (-> Text (Maybe AST)) + (case class + (^template [ ] + + (#;Some (' ))) + (["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)] + ["void" ;Unit]) + + _ + #;None)) + +(def: (auto-primitive-to-type class) + (-> Text (Maybe AST)) + (case class + (^template [ ] + + (#;Some (' ))) + (["boolean" ;Bool] + ["byte" ;Int] + ["short" ;Int] + ["int" ;Int] + ["long" ;Int] + ["float" ;Real] + ["double" ;Real] + ["char" ;Char] + ["void" ;Unit]) + + _ + #;None)) + +(def: (generic-class->type' mode type-params in-array? name+params + class->type') + (-> Primitive-Mode (List TypeParam) Bool [Text (List GenericType)] + (-> Primitive-Mode (List TypeParam) Bool GenericType AST) + AST) + (case [name+params mode in-array?] + (^=> [[prim #;Nil] #ManualPrM false] + [(manual-primitive-to-type prim) (#;Some output)]) + output + + (^=> [[prim #;Nil] #AutoPrM false] + [(auto-primitive-to-type prim) (#;Some output)]) + output + + [[name params] _ _] + (let [=params (map (class->type' mode type-params in-array?) params)] + (` (host (~ (ast;symbol ["" name])) [(~@ =params)]))))) + +(def: (class->type' mode type-params in-array? class) + (-> Primitive-Mode (List TypeParam) Bool GenericType AST) + (case class + (#GenericTypeVar name) + (case (find (lambda [[pname pbounds]] + (and (Text/= name pname) + (not (list;empty? pbounds)))) + type-params) + #;None + (ast;symbol ["" name]) + + (#;Some [pname pbounds]) + (class->type' mode type-params in-array? (default (undefined) (list;head pbounds)))) + + (#GenericClass name+params) + (generic-class->type' mode type-params in-array? name+params + class->type') + + (#GenericArray param) + (let [=param (class->type' mode type-params true param)] + (` (host (~ (ast;symbol ["" array-type-name])) [(~ =param)]))) + + (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _]))) + (' (;Ex [*] *)) + + (#GenericWildcard (#;Some [#UpperBound upper-bound])) + (class->type' mode type-params in-array? upper-bound) + )) + +(def: (class->type mode type-params class) + (-> Primitive-Mode (List TypeParam) GenericType AST) + (class->type' mode type-params false class)) + +(def: (type-param-type$ [name bounds]) + (-> TypeParam AST) + (ast;symbol ["" name])) + +(def: (class-decl-type$ (^slots [#class-name #class-params])) + (-> ClassDecl AST) + (let [=params (map (: (-> TypeParam AST) + (lambda [[pname pbounds]] + (case pbounds + #;Nil + (ast;symbol ["" pname]) + + (#;Cons bound1 _) + (class->type #ManualPrM class-params bound1)))) + class-params)] + (` (host (~ (ast;symbol ["" class-name])) [(~@ =params)])))) + +(def: (stack-trace->text trace) + (-> StackTrace Text) + (let [size (_lux_proc ["jvm" "arraylength"] [trace]) + idxs (list;n.range +0 (n.dec size))] + (|> idxs + (map (: (-> Nat Text) + (lambda [idx] + (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] + [(_lux_proc ["jvm" "aaload"] [trace idx])])))) + (text;join-with "\n") + ))) + +(def: (get-stack-trace t) + (-> (host java.lang.Throwable) StackTrace) + (_lux_proc ["jvm" "invokevirtual:java.lang.Throwable:getStackTrace:"] [t])) + +(def: #hidden (throwable->text t) + (All [a] (-> (host java.lang.Throwable) (Either Text a))) + (#;Left (format (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [t]) + "\n" + (|> t get-stack-trace stack-trace->text)))) + +(def: empty-imports + ClassImports + (list)) + +(def: (get-import name imports) + (-> Text ClassImports (Maybe Text)) + (:: Functor map product;right + (find (|>. product;left (Text/= name)) + imports))) + +(def: (add-import short+full imports) + (-> [Text Text] ClassImports ClassImports) + (#;Cons short+full imports)) + +(def: (class-imports compiler) + (-> Compiler ClassImports) + (case (compiler;run compiler + (: (Lux ClassImports) + (do Monad + [current-module compiler;current-module-name + defs (compiler;defs current-module)] + (wrap (fold (: (-> [Text Def] ClassImports ClassImports) + (lambda [[short-name [_ meta _]] imports] + (case (compiler;get-text-ann (ident-for #;;jvm-class) meta) + (#;Some full-class-name) + (add-import [short-name full-class-name] imports) + + _ + imports))) + empty-imports + defs))))) + (#;Left _) (list) + (#;Right imports) imports)) + +(def: java.lang-classes + (List Text) + (list ## Interfaces + "Appendable" + "AutoCloseable" + "CharSequence" + "Cloneable" + "Comparable" + "Iterable" + "Readable" + "Runnable" + + ## Classes + "Boolean" + "Byte" + "Character" + "Class" + "ClassLoader" + "ClassValue" + "Compiler" + "Double" + "Enum" + "Float" + "InheritableThreadLocal" + "Integer" + "Long" + "Math" + "Number" + "Object" + "Package" + "Process" + "ProcessBuilder" + "Runtime" + "RuntimePermission" + "SecurityManager" + "Short" + "StackTraceElement" + "StrictMath" + "String" + "StringBuffer" + "StringBuilder" + "System" + "Thread" + "ThreadGroup" + "ThreadLocal" + "Throwable" + "Void" + + ## Exceptions + "ArithmeticException" + "ArrayIndexOutOfBoundsException" + "ArrayStoreException" + "ClassCastException" + "ClassNotFoundException" + "CloneNotSupportedException" + "EnumConstantNotPresentException" + "Exception" + "IllegalAccessException" + "IllegalArgumentException" + "IllegalMonitorStateException" + "IllegalStateException" + "IllegalThreadStateException" + "IndexOutOfBoundsException" + "InstantiationException" + "InterruptedException" + "NegativeArraySizeException" + "NoSuchFieldException" + "NoSuchMethodException" + "NullPointerException" + "NumberFormatException" + "ReflectiveOperationException" + "RuntimeException" + "SecurityException" + "StringIndexOutOfBoundsException" + "TypeNotPresentException" + "UnsupportedOperationException" + + ## Annotations + "Deprecated" + "Override" + "SafeVarargs" + "SuppressWarnings")) + +(def: (fully-qualified-class-name? name) + (-> Text Bool) + (text;contains? "." name)) + +(def: (fully-qualify-class-name imports name) + (-> ClassImports Text Text) + (cond (fully-qualified-class-name? name) + name + + (member? text;Eq java.lang-classes name) + (format "java.lang." name) + + ## else + (default name (get-import name imports)))) + +(def: type-var-class Text "java.lang.Object") + +(def: (simple-class$ params class) + (-> (List TypeParam) GenericType Text) + (case class + (#GenericTypeVar name) + (case (find (lambda [[pname pbounds]] + (and (Text/= name pname) + (not (list;empty? pbounds)))) + params) + #;None + type-var-class + + (#;Some [pname pbounds]) + (simple-class$ params (default (undefined) (list;head pbounds)))) + + (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _]))) + type-var-class + + (#GenericWildcard (#;Some [#UpperBound upper-bound])) + (simple-class$ params upper-bound) + + (#GenericClass name params) + name + + (#GenericArray param') + (case param' + (#GenericArray param) + (format "[" (simple-class$ params param)) + + (^template [ ] + (#GenericClass #;Nil) + ) + (["boolean" "[Z"] + ["byte" "[B"] + ["short" "[S"] + ["int" "[I"] + ["long" "[J"] + ["float" "[F"] + ["double" "[D"] + ["char" "[C"]) + + param + (format "[L" (simple-class$ params param) ";")) + )) + +(def: (make-get-const-parser class-name field-name) + (-> Text Text (Syntax AST)) + (do s;Monad + [#let [dotted-name (format "." field-name)] + _ (s;this! (ast;symbol ["" dotted-name]))] + (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" class-name ":" field-name)))] []))))) + +(def: (make-get-var-parser class-name field-name) + (-> Text Text (Syntax AST)) + (do s;Monad + [#let [dotted-name (format "." field-name)] + _ (s;this! (ast;symbol ["" dotted-name]))] + (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" class-name ":" field-name)))] [_jvm_this]))))) + +(def: (make-put-var-parser class-name field-name) + (-> Text Text (Syntax AST)) + (do s;Monad + [#let [dotted-name (format "." field-name)] + [_ _ value] (: (Syntax [Unit Unit AST]) + (s;form ($_ s;seq (s;this! (' :=)) (s;this! (ast;symbol ["" dotted-name])) s;any)))] + (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "putfield" ":" class-name ":" field-name)))] [_jvm_this (~ value)]))))) + +(def: (pre-walk-replace f input) + (-> (-> AST AST) AST AST) + (case (f input) + (^template [] + [meta ( parts)] + [meta ( (map (pre-walk-replace f) parts))]) + ([#;FormS] + [#;TupleS]) + + [meta (#;RecordS pairs)] + [meta (#;RecordS (map (: (-> [AST AST] [AST AST]) + (lambda [[key val]] + [(pre-walk-replace f key) (pre-walk-replace f val)])) + pairs))] + + ast' + ast')) + +(def: (parser->replacer p ast) + (-> (Syntax AST) (-> AST AST)) + (case (s;run (list ast) p) + (#;Right [#;Nil ast']) + ast' + + _ + ast + )) + +(def: (field->parser class-name [[field-name _ _] field]) + (-> Text [MemberDecl FieldDecl] (Syntax AST)) + (case field + (#ConstantField _) + (make-get-const-parser class-name field-name) + + (#VariableField _) + (s;either (make-get-var-parser class-name field-name) + (make-put-var-parser class-name field-name)))) + +(def: (make-constructor-parser params class-name arg-decls) + (-> (List TypeParam) Text (List ArgDecl) (Syntax AST)) + (do s;Monad + [[_ args] (: (Syntax [Unit (List AST)]) + (s;form ($_ s;seq (s;this! (' .new!)) (s;tuple (s;exactly (list;size arg-decls) s;any))))) + #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] + (wrap (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" class-name ":" (text;join-with "," arg-decls'))))] + [(~@ args)]))))) + +(def: (make-static-method-parser params class-name method-name arg-decls) + (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST)) + (do s;Monad + [#let [dotted-name (format "." method-name "!")] + [_ args] (: (Syntax [Unit (List AST)]) + (s;form ($_ s;seq (s;this! (ast;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any))))) + #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] + (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokestatic" ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] + [(~@ args)]))))) + +(do-template [ ] + [(def: ( params class-name method-name arg-decls) + (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST)) + (do s;Monad + [#let [dotted-name (format "." method-name "!")] + [_ args] (: (Syntax [Unit (List AST)]) + (s;form ($_ s;seq (s;this! (ast;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any))))) + #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] + (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] + [(~' _jvm_this) (~@ args)])))))] + + [make-special-method-parser "invokespecial"] + [make-virtual-method-parser "invokevirtual"] + ) + +(def: (method->parser params class-name [[method-name _ _] meth-def]) + (-> (List TypeParam) Text [MemberDecl MethodDef] (Syntax AST)) + (case meth-def + (#ConstructorMethod strict? type-vars args constructor-args return-expr exs) + (make-constructor-parser params class-name args) + + (#StaticMethod strict? type-vars args return-type return-expr exs) + (make-static-method-parser params class-name method-name args) + + (^or (#VirtualMethod final? strict? type-vars args return-type return-expr exs) (#OverridenMethod strict? owner-class type-vars args return-type return-expr exs)) + (make-special-method-parser params class-name method-name args) + + (#AbstractMethod type-vars args return-type exs) + (make-virtual-method-parser params class-name method-name args) + + (#NativeMethod type-vars args return-type exs) + (make-virtual-method-parser params class-name method-name args))) + +## Syntaxs +(def: (full-class-name^ imports) + (-> ClassImports (Syntax Text)) + (do s;Monad + [name s;local-symbol] + (wrap (fully-qualify-class-name imports name)))) + +(def: privacy-modifier^ + (Syntax PrivacyModifier) + (let [(^open) s;Monad] + ($_ s;alt + (s;this! (' #public)) + (s;this! (' #private)) + (s;this! (' #protected)) + (wrap [])))) + +(def: inheritance-modifier^ + (Syntax InheritanceModifier) + (let [(^open) s;Monad] + ($_ s;alt + (s;this! (' #final)) + (s;this! (' #abstract)) + (wrap [])))) + +(def: bound-kind^ + (Syntax BoundKind) + (s;alt (s;this! (' <)) + (s;this! (' >)))) + +(def: (generic-type^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax GenericType)) + ($_ s;either + (do s;Monad + [_ (s;this! (' ?))] + (wrap (#GenericWildcard #;None))) + (s;tuple (do s;Monad + [_ (s;this! (' ?)) + bound-kind bound-kind^ + bound (generic-type^ imports type-vars)] + (wrap (#GenericWildcard (#;Some [bound-kind bound]))))) + (do s;Monad + [name (full-class-name^ imports)] + (let% [ (do-template [ ] + [(Text/= name) + (wrap (#GenericClass (list)))] + + ["[Z" "Boolean-Array"] + ["[B" "Byte-Array"] + ["[S" "Short-Array"] + ["[I" "Int-Array"] + ["[J" "Long-Array"] + ["[F" "Float-Array"] + ["[D" "Double-Array"] + ["[C" "Char-Array"])] + (cond (member? text;Eq (map product;left type-vars) name) + (wrap (#GenericTypeVar name)) + + + + ## else + (wrap (#GenericClass name (list)))))) + (s;form (do s;Monad + [name (s;this! (' Array)) + component (generic-type^ imports type-vars)] + (case component + (^template [ ] + (#GenericClass #;Nil) + (wrap (#GenericClass (list)))) + (["[Z" "boolean"] + ["[B" "byte"] + ["[S" "short"] + ["[I" "int"] + ["[J" "long"] + ["[F" "float"] + ["[D" "double"] + ["[C" "char"]) + + _ + (wrap (#GenericArray component))))) + (s;form (do s;Monad + [name (full-class-name^ imports) + params (s;some (generic-type^ imports type-vars)) + _ (s;assert (format name " can't be a type-parameter!") + (not (member? text;Eq (map product;left type-vars) name)))] + (wrap (#GenericClass name params)))) + )) + +(def: (type-param^ imports) + (-> ClassImports (Syntax TypeParam)) + (s;either (do s;Monad + [param-name s;local-symbol] + (wrap [param-name (list)])) + (s;tuple (do s;Monad + [param-name s;local-symbol + _ (s;this! (' <)) + bounds (s;many (generic-type^ imports (list)))] + (wrap [param-name bounds]))))) + +(def: (type-params^ imports) + (-> ClassImports (Syntax (List TypeParam))) + (s;tuple (s;some (type-param^ imports)))) + +(def: (class-decl^ imports) + (-> ClassImports (Syntax ClassDecl)) + (s;either (do s;Monad + [name (full-class-name^ imports)] + (wrap [name (list)])) + (s;form (do s;Monad + [name (full-class-name^ imports) + params (s;some (type-param^ imports))] + (wrap [name params]))) + )) + +(def: (super-class-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax SuperClassDecl)) + (s;either (do s;Monad + [name (full-class-name^ imports)] + (wrap [name (list)])) + (s;form (do s;Monad + [name (full-class-name^ imports) + params (s;some (generic-type^ imports type-vars))] + (wrap [name params]))))) + +(def: annotation-params^ + (Syntax (List AnnotationParam)) + (s;record (s;some (s;seq s;local-tag s;any)))) + +(def: (annotation^ imports) + (-> ClassImports (Syntax Annotation)) + (s;either (do s;Monad + [ann-name (full-class-name^ imports)] + (wrap [ann-name (list)])) + (s;form (s;seq (full-class-name^ imports) + annotation-params^)))) + +(def: (annotations^' imports) + (-> ClassImports (Syntax (List Annotation))) + (do s;Monad + [_ (s;this! (' #ann))] + (s;tuple (s;some (annotation^ imports))))) + +(def: (annotations^ imports) + (-> ClassImports (Syntax (List Annotation))) + (do s;Monad + [anns?? (s;opt (annotations^' imports))] + (wrap (default (list) anns??)))) + +(def: (throws-decl'^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List GenericType))) + (do s;Monad + [_ (s;this! (' #throws))] + (s;tuple (s;some (generic-type^ imports type-vars))))) + +(def: (throws-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List GenericType))) + (do s;Monad + [exs? (s;opt (throws-decl'^ imports type-vars))] + (wrap (default (list) exs?)))) + +(def: (method-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDecl])) + (s;form (do s;Monad + [tvars (s;default (list) (type-params^ imports)) + name s;local-symbol + anns (annotations^ imports) + inputs (s;tuple (s;some (generic-type^ imports type-vars))) + output (generic-type^ imports type-vars) + exs (throws-decl^ imports type-vars)] + (wrap [[name #PublicPM anns] {#method-tvars tvars + #method-inputs inputs + #method-output output + #method-exs exs}])))) + +(def: state-modifier^ + (Syntax StateModifier) + ($_ s;alt + (s;this! (' #volatile)) + (s;this! (' #final)) + (:: s;Monad wrap []))) + +(def: (field-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl FieldDecl])) + (s;either (s;form (do s;Monad + [_ (s;this! (' #const)) + name s;local-symbol + anns (annotations^ imports) + type (generic-type^ imports type-vars) + body s;any] + (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) + (s;form (do s;Monad + [pm privacy-modifier^ + sm state-modifier^ + name s;local-symbol + anns (annotations^ imports) + type (generic-type^ imports type-vars)] + (wrap [[name pm anns] (#VariableField [sm type])]))))) + +(def: (arg-decl^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax ArgDecl)) + (s;tuple (s;seq s;local-symbol + (generic-type^ imports type-vars)))) + +(def: (arg-decls^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List ArgDecl))) + (s;some (arg-decl^ imports type-vars))) + +(def: (constructor-arg^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax ConstructorArg)) + (s;tuple (s;seq (generic-type^ imports type-vars) s;any))) + +(def: (constructor-args^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List ConstructorArg))) + (s;tuple (s;some (constructor-arg^ imports type-vars)))) + +(def: (constructor-method^ imports class-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad + [pm privacy-modifier^ + strict-fp? (s;this? (' #strict)) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars (List/append class-vars method-vars)] + [_ arg-decls] (s;form (s;seq (s;this! (' new)) + (arg-decls^ imports total-vars))) + constructor-args (constructor-args^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s;any] + (wrap [{#member-name constructor-method-name + #member-privacy pm + #member-anns annotations} + (#ConstructorMethod strict-fp? method-vars arg-decls constructor-args body exs)])))) + +(def: (virtual-method-def^ imports class-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad + [pm privacy-modifier^ + strict-fp? (s;this? (' #strict)) + final? (s;this? (' #final)) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars (List/append class-vars method-vars)] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s;any] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#VirtualMethod final? strict-fp? method-vars arg-decls return-type body exs)])))) + +(def: (overriden-method-def^ imports) + (-> ClassImports (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad + [strict-fp? (s;this? (' #strict)) + owner-class (class-decl^ imports) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars (List/append (product;right owner-class) method-vars)] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s;any] + (wrap [{#member-name name + #member-privacy #PublicPM + #member-anns annotations} + (#OverridenMethod strict-fp? owner-class method-vars arg-decls return-type body exs)])))) + +(def: (static-method-def^ imports) + (-> ClassImports (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad + [pm privacy-modifier^ + strict-fp? (s;this? (' #strict)) + _ (s;this! (' #static)) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars method-vars] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s;any] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#StaticMethod strict-fp? method-vars arg-decls return-type body exs)])))) + +(def: (abstract-method-def^ imports) + (-> ClassImports (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad + [pm privacy-modifier^ + _ (s;this! (' #abstract)) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars method-vars] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports)] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#AbstractMethod method-vars arg-decls return-type exs)])))) + +(def: (native-method-def^ imports) + (-> ClassImports (Syntax [MemberDecl MethodDef])) + (s;form (do s;Monad + [pm privacy-modifier^ + _ (s;this! (' #native)) + method-vars (s;default (list) (type-params^ imports)) + #let [total-vars method-vars] + [name arg-decls] (s;form (s;seq s;local-symbol + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports)] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#NativeMethod method-vars arg-decls return-type exs)])))) + +(def: (method-def^ imports class-vars) + (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) + ($_ s;either + (constructor-method^ imports class-vars) + (virtual-method-def^ imports class-vars) + (overriden-method-def^ imports) + (static-method-def^ imports) + (abstract-method-def^ imports) + (native-method-def^ imports))) + +(def: partial-call^ + (Syntax PartialCall) + (s;form (s;seq s;any s;any))) + +(def: class-kind^ + (Syntax ClassKind) + (s;either (do s;Monad + [_ (s;this! (' #class))] + (wrap #Class)) + (do s;Monad + [_ (s;this! (' #interface))] + (wrap #Interface)) + )) + +(def: import-member-alias^ + (Syntax (Maybe Text)) + (s;opt (do s;Monad + [_ (s;this! (' #as))] + s;local-symbol))) + +(def: (import-member-args^ imports type-vars) + (-> ClassImports (List TypeParam) (Syntax (List [Bool GenericType]))) + (s;tuple (s;some (s;seq (s;this? (' #?)) (generic-type^ imports type-vars))))) + +(def: import-member-return-flags^ + (Syntax [Bool Bool Bool]) + ($_ s;seq (s;this? (' #io)) (s;this? (' #try)) (s;this? (' #?)))) + +(def: primitive-mode^ + (Syntax Primitive-Mode) + (s;alt (s;this! (' #manual)) + (s;this! (' #auto)))) + +(def: (import-member-decl^ imports owner-vars) + (-> ClassImports (List TypeParam) (Syntax ImportMemberDecl)) + ($_ s;either + (s;form (do s;Monad + [_ (s;this! (' #enum)) + enum-members (s;some s;local-symbol)] + (wrap (#EnumDecl enum-members)))) + (s;form (do s;Monad + [tvars (s;default (list) (type-params^ imports)) + _ (s;this! (' new)) + ?alias import-member-alias^ + #let [total-vars (List/append owner-vars tvars)] + ?prim-mode (s;opt primitive-mode^) + args (import-member-args^ imports total-vars) + [io? try? maybe?] import-member-return-flags^] + (wrap (#ConstructorDecl [{#import-member-mode (default #AutoPrM ?prim-mode) + #import-member-alias (default "new" ?alias) + #import-member-kind #VirtualIMK + #import-member-tvars tvars + #import-member-args args + #import-member-maybe? maybe? + #import-member-try? try? + #import-member-io? io?} + {}])) + )) + (s;form (do s;Monad + [kind (: (Syntax ImportMethodKind) + (s;alt (s;this! (' #static)) + (wrap []))) + tvars (s;default (list) (type-params^ imports)) + name s;local-symbol + ?alias import-member-alias^ + #let [total-vars (List/append owner-vars tvars)] + ?prim-mode (s;opt primitive-mode^) + args (import-member-args^ imports total-vars) + [io? try? maybe?] import-member-return-flags^ + return (generic-type^ imports total-vars)] + (wrap (#MethodDecl [{#import-member-mode (default #AutoPrM ?prim-mode) + #import-member-alias (default name ?alias) + #import-member-kind kind + #import-member-tvars tvars + #import-member-args args + #import-member-maybe? maybe? + #import-member-try? try? + #import-member-io? io?} + {#import-method-name name + #import-method-return return + }])))) + (s;form (do s;Monad + [static? (s;this? (' #static)) + name s;local-symbol + ?prim-mode (s;opt primitive-mode^) + gtype (generic-type^ imports owner-vars) + maybe? (s;this? (' #?)) + setter? (s;this? (' #!))] + (wrap (#FieldAccessDecl {#import-field-mode (default #AutoPrM ?prim-mode) + #import-field-name name + #import-field-static? static? + #import-field-maybe? maybe? + #import-field-setter? setter? + #import-field-type gtype})))) + )) + +## Generators +(def: with-parens + (-> Code Code) + (text;enclose ["(" ")"])) + +(def: with-brackets + (-> Code Code) + (text;enclose ["[" "]"])) + +(def: spaced + (-> (List Code) Code) + (text;join-with " ")) + +(def: (privacy-modifier$ pm) + (-> PrivacyModifier Code) + (case pm + #PublicPM "public" + #PrivatePM "private" + #ProtectedPM "protected" + #DefaultPM "default")) + +(def: (inheritance-modifier$ im) + (-> InheritanceModifier Code) + (case im + #FinalIM "final" + #AbstractIM "abstract" + #DefaultIM "default")) + +(def: (annotation-param$ [name value]) + (-> AnnotationParam Code) + (format name "=" (ast;to-text value))) + +(def: (annotation$ [name params]) + (-> Annotation Code) + (format "(" name " " "{" (text;join-with "\t" (map annotation-param$ params)) "}" ")")) + +(def: (bound-kind$ kind) + (-> BoundKind Code) + (case kind + #UpperBound "<" + #LowerBound ">")) + +(def: (generic-type$ gtype) + (-> GenericType Code) + (case gtype + (#GenericTypeVar name) + name + + (#GenericClass name params) + (format "(" name " " (spaced (map generic-type$ params)) ")") + + (#GenericArray param) + (format "(" array-type-name " " (generic-type$ param) ")") + + (#GenericWildcard #;None) + "?" + + (#GenericWildcard (#;Some [bound-kind bound])) + (format (bound-kind$ bound-kind) (generic-type$ bound)))) + +(def: (type-param$ [name bounds]) + (-> TypeParam Code) + (format "(" name " " (spaced (map generic-type$ bounds)) ")")) + +(def: (class-decl$ (^open)) + (-> ClassDecl Code) + (format "(" class-name " " (spaced (map type-param$ class-params)) ")")) + +(def: (super-class-decl$ (^slots [#super-class-name #super-class-params])) + (-> SuperClassDecl Code) + (format "(" super-class-name " " (spaced (map generic-type$ super-class-params)) ")")) + +(def: (method-decl$ [[name pm anns] method-decl]) + (-> [MemberDecl MethodDecl] Code) + (let [(^slots [#method-tvars #method-inputs #method-output #method-exs]) method-decl] + (with-parens + (spaced (list name + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ method-tvars))) + (with-brackets (spaced (map generic-type$ method-exs))) + (with-brackets (spaced (map generic-type$ method-inputs))) + (generic-type$ method-output)) + )))) + +(def: (state-modifier$ sm) + (-> StateModifier Code) + (case sm + #VolatileSM "volatile" + #FinalSM "final" + #DefaultSM "default")) + +(def: (field-decl$ [[name pm anns] field]) + (-> [MemberDecl FieldDecl] Code) + (case field + (#ConstantField class value) + (with-parens + (spaced (list "constant" name + (with-brackets (spaced (map annotation$ anns))) + (generic-type$ class) + (ast;to-text value)) + )) + + (#VariableField sm class) + (with-parens + (spaced (list "variable" name + (privacy-modifier$ pm) + (state-modifier$ sm) + (with-brackets (spaced (map annotation$ anns))) + (generic-type$ class)) + )) + )) + +(def: (arg-decl$ [name type]) + (-> ArgDecl Code) + (with-parens + (spaced (list name (generic-type$ type))))) + +(def: (constructor-arg$ [class term]) + (-> ConstructorArg Code) + (with-brackets + (spaced (list (generic-type$ class) (ast;to-text term))))) + +(def: (method-def$ replacer super-class [[name pm anns] method-def]) + (-> (-> AST AST) SuperClassDecl [MemberDecl MethodDef] Code) + (case method-def + (#ConstructorMethod strict-fp? type-vars arg-decls constructor-args body exs) + (with-parens + (spaced (list "init" + (privacy-modifier$ pm) + (Bool/encode strict-fp?) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (with-brackets (spaced (map constructor-arg$ constructor-args))) + (ast;to-text (pre-walk-replace replacer body)) + ))) + + (#VirtualMethod final? strict-fp? type-vars arg-decls return-type body exs) + (with-parens + (spaced (list "virtual" + name + (privacy-modifier$ pm) + (Bool/encode final?) + (Bool/encode strict-fp?) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type) + (ast;to-text (pre-walk-replace replacer body))))) + + (#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs) + (let [super-replacer (parser->replacer (s;form (do s;Monad + [_ (s;this! (' .super!)) + args (s;tuple (s;exactly (list;size arg-decls) s;any)) + #let [arg-decls' (: (List Text) (map (. (simple-class$ (list)) product;right) + arg-decls))]] + (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokespecial" ":" (get@ #super-class-name super-class) ":" name ":" (text;join-with "," arg-decls'))))] + [(~' _jvm_this) (~@ args)]))))))] + (with-parens + (spaced (list "override" + (class-decl$ class-decl) + name + (Bool/encode strict-fp?) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type) + (|> body + (pre-walk-replace replacer) + (pre-walk-replace super-replacer) + (ast;to-text)) + )))) + + (#StaticMethod strict-fp? type-vars arg-decls return-type body exs) + (with-parens + (spaced (list "static" + name + (privacy-modifier$ pm) + (Bool/encode strict-fp?) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type) + (ast;to-text (pre-walk-replace replacer body))))) + + (#AbstractMethod type-vars arg-decls return-type exs) + (with-parens + (spaced (list "abstract" + name + (privacy-modifier$ pm) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type)))) + + (#NativeMethod type-vars arg-decls return-type exs) + (with-parens + (spaced (list "native" + name + (privacy-modifier$ pm) + (with-brackets (spaced (map annotation$ anns))) + (with-brackets (spaced (map type-param$ type-vars))) + (with-brackets (spaced (map generic-type$ exs))) + (with-brackets (spaced (map arg-decl$ arg-decls))) + (generic-type$ return-type)))) + )) + +(def: (complete-call$ obj [method args]) + (-> AST PartialCall AST) + (` ((~ method) (~ args) (~ obj)))) + +## [Syntax] +(def: object-super-class + SuperClassDecl + {#super-class-name "java.lang.Object" + #super-class-params (list)}) + +(syntax: #export (class: [#let [imports (class-imports *compiler*)]] + [im inheritance-modifier^] + [class-decl (class-decl^ imports)] + [#let [full-class-name (product;left class-decl) + imports (add-import [(short-class-name full-class-name) full-class-name] + (class-imports *compiler*))]] + [#let [class-vars (product;right class-decl)]] + [super (s;default object-super-class + (super-class-decl^ imports class-vars))] + [interfaces (s;default (list) + (s;tuple (s;some (super-class-decl^ imports class-vars))))] + [annotations (annotations^ imports)] + [fields (s;some (field-decl^ imports class-vars))] + [methods (s;some (method-def^ imports class-vars))]) + {#;doc (doc "Allows defining JVM classes in Lux code." + "For example:" + (class: #final (JvmPromise A) [] + ## Fields + (#private resolved boolean) + (#private datum A) + (#private waitingList (java.util.List lux.Function)) + ## Methods + (#public [] new [] [] + (exec (:= .resolved false) + (:= .waitingList (ArrayList.new [])) + [])) + (#public [] resolve [{value A}] boolean + (let [container (.new! [])] + (synchronized _jvm_this + (if .resolved + false + (exec (:= .datum value) + (:= .resolved true) + (let [sleepers .waitingList + sleepers-count (java.util.List.size [] sleepers)] + (map (lambda [idx] + (let [sleeper (java.util.List.get [(l2i idx)] sleepers)] + (Executor.execute [(@runnable (lux.Function.apply [(:! Object value)] sleeper))] + executor))) + (i.range 0 (i.dec (i2l sleepers-count))))) + (:= .waitingList (null)) + true))))) + (#public [] poll [] A + .datum) + (#public [] wasResolved [] boolean + (synchronized _jvm_this + .resolved)) + (#public [] waitOn [{callback lux.Function}] void + (synchronized _jvm_this + (exec (if .resolved + (lux.Function.apply [(:! Object .datum)] callback) + (:! Object (java.util.List.add [callback] .waitingList))) + []))) + (#public #static [A] make [{value A}] (lux.concurrency.promise.JvmPromise A) + (let [container (.new! [])] + (exec (.resolve! (:! (host lux.concurrency.promise.JvmPromise [Unit]) container) [(:! Unit value)]) + container)))) + + "The vector corresponds to parent interfaces." + "An optional super-class can be specified before the vector. If not specified, java.lang.Object will be assumed." + "Fields and methods defined in the class can be used with special syntax." + "For example:" + ".resolved, for accessing the \"resolved\" field." + "(:= .resolved true) for modifying it." + "(.new! []) for calling the class's constructor." + "(.resolve! container [value]) for calling the \"resolve\" method." + )} + (do Monad + [current-module compiler;current-module-name + #let [fully-qualified-class-name (format (text;replace "/" "." current-module) "." full-class-name) + field-parsers (map (field->parser fully-qualified-class-name) fields) + method-parsers (map (method->parser (product;right class-decl) fully-qualified-class-name) methods) + replacer (parser->replacer (fold s;either + (s;fail "") + (List/append field-parsers method-parsers))) + def-code (format "class:" + (spaced (list (class-decl$ class-decl) + (super-class-decl$ super) + (with-brackets (spaced (map super-class-decl$ interfaces))) + (inheritance-modifier$ im) + (with-brackets (spaced (map annotation$ annotations))) + (with-brackets (spaced (map field-decl$ fields))) + (with-brackets (spaced (map (method-def$ replacer super) methods))))))]] + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))) + +(syntax: #export (interface: [#let [imports (class-imports *compiler*)]] + [class-decl (class-decl^ imports)] + [#let [full-class-name (product;left class-decl) + imports (add-import [(short-class-name full-class-name) full-class-name] + (class-imports *compiler*))]] + [#let [class-vars (product;right class-decl)]] + [supers (s;default (list) + (s;tuple (s;some (super-class-decl^ imports class-vars))))] + [annotations (annotations^ imports)] + [members (s;some (method-decl^ imports class-vars))]) + {#;doc (doc "Allows defining JVM interfaces." + (interface: TestInterface + ([] foo [boolean String] void #throws [Exception])))} + (let [def-code (format "interface:" + (spaced (list (class-decl$ class-decl) + (with-brackets (spaced (map super-class-decl$ supers))) + (with-brackets (spaced (map annotation$ annotations))) + (spaced (map method-decl$ members)))))] + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))) + )) + +(syntax: #export (object [#let [imports (class-imports *compiler*)]] + [#let [class-vars (list)]] + [super (s;default object-super-class + (super-class-decl^ imports class-vars))] + [interfaces (s;default (list) + (s;tuple (s;some (super-class-decl^ imports class-vars))))] + [constructor-args (constructor-args^ imports class-vars)] + [methods (s;some (overriden-method-def^ imports))]) + {#;doc (doc "Allows defining anonymous classes." + "The 1st vector corresponds to parent interfaces." + "The 2nd vector corresponds to arguments to the super class constructor." + "An optional super-class can be specified before the 1st vector. If not specified, java.lang.Object will be assumed." + (object [java.lang.Runnable] + [] + (java.lang.Runnable (run) void + (exec (do-something some-input) + []))) + )} + (let [def-code (format "anon-class:" + (spaced (list (super-class-decl$ super) + (with-brackets (spaced (map super-class-decl$ interfaces))) + (with-brackets (spaced (map constructor-arg$ constructor-args))) + (with-brackets (spaced (map (method-def$ id super) methods))))))] + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))) + +(syntax: #export (null) + {#;doc (doc "Null object reference." + (null))} + (wrap (list (` (;_lux_proc ["jvm" "null"] []))))) + +(def: #export (null? obj) + {#;doc (doc "Test for null object reference." + (null? (null)) + "=>" + true + (null? "YOLO") + "=>" + false)} + (-> (host java.lang.Object) Bool) + (;_lux_proc ["jvm" "null?"] [obj])) + +(syntax: #export (??? expr) + {#;doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it." + (??? (: java.lang.String (null))) + "=>" + #;None + (??? "YOLO") + "=>" + (#;Some "YOLO"))} + (with-gensyms [g!temp] + (wrap (list (` (let [(~ g!temp) (~ expr)] + (if (;_lux_proc ["jvm" "null?"] [(~ g!temp)]) + #;None + (#;Some (~ g!temp))))))))) + +(syntax: #export (!!! expr) + {#;doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType." + "A #;None would get translated into a (null)." + (!!! (??? (: java.lang.Thread (null)))) + "=>" + (null) + (!!! (??? "YOLO")) + "=>" + "YOLO")} + (with-gensyms [g!value] + (wrap (list (` (;_lux_case (~ expr) + (#;Some (~ g!value)) + (~ g!value) + + #;None + (;_lux_proc ["jvm" "null"] []))))))) + +(syntax: #export (try expr) + {#;doc (doc "Covers the expression in a try-catch block." + "If it succeeds, you get (#;Right result)." + "If it fails, you get (#;Left error+stack-traces-as-text)." + (try (risky-computation input)))} + (wrap (list (`' (_lux_proc ["jvm" "try"] + [(#;Right (~ expr)) + ;;throwable->text]))))) + +(syntax: #export (instance? [#let [imports (class-imports *compiler*)]] + [class (generic-type^ imports (list))] + [obj (s;opt s;any)]) + {#;doc (doc "Checks whether an object is an instance of a particular class." + "Caveat emptor: Can't check for polymorphism, so avoid using parameterized classes." + (instance? String "YOLO"))} + (case obj + (#;Some obj) + (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ obj)])))) + + #;None + (do @ + [g!obj (compiler;gensym "obj")] + (wrap (list (` (: (-> (host (~' java.lang.Object)) Bool) + (lambda [(~ g!obj)] + (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ g!obj)]))))))) + )) + +(syntax: #export (synchronized lock body) + {#;doc (doc "Evaluates body, while holding a lock on a given object." + (synchronized object-to-be-locked + (exec (do-something ...) + (do-something-else ...) + (finish-the-computation ...))))} + (wrap (list (` (;_lux_proc ["jvm" "synchronized"] [(~ lock) (~ body)]))))) + +(syntax: #export (do-to obj [methods (s;some partial-call^)]) + {#;doc (doc "Call a variety of methods on an object; then return the object." + (do-to vreq + (HttpServerRequest.setExpectMultipart [true]) + (ReadStream.handler [(object [(Handler Buffer)] + [] + ((Handler A) (handle [buffer A]) void + (io;run (do Monad + [_ (write (Buffer.getBytes [] buffer) body)] + (wrap [])))) + )]) + (ReadStream.endHandler [[(object [(Handler Void)] + [] + ((Handler A) (handle [_ A]) void + (exec (do Monad + [#let [_ (io;run (close body))] + response (handler (request$ vreq body))] + (respond! response vreq)) + [])) + )]])))} + (with-gensyms [g!obj] + (wrap (list (` (let [(~ g!obj) (~ obj)] + (exec (~@ (map (complete-call$ g!obj) methods)) + (~ g!obj)))))))) + +(def: (class-import$ long-name? [full-name params]) + (-> Bool ClassDecl AST) + (let [def-name (if long-name? + full-name + (short-class-name full-name))] + (case params + #;Nil + (` (def: (~ (ast;symbol ["" def-name])) + {#;type? true + #;;jvm-class (~ (ast;text full-name))} + Type + (host (~ (ast;symbol ["" full-name]))))) + + (#;Cons _) + (let [params' (map (lambda [[p _]] (ast;symbol ["" p])) params)] + (` (def: (~ (ast;symbol ["" def-name])) + {#;type? true + #;;jvm-class (~ (ast;text full-name))} + Type + (All [(~@ params')] + (host (~ (ast;symbol ["" full-name])) + [(~@ params')])))))))) + +(def: (member-type-vars class-tvars member) + (-> (List TypeParam) ImportMemberDecl (List TypeParam)) + (case member + (#ConstructorDecl [commons _]) + (List/append class-tvars (get@ #import-member-tvars commons)) + + (#MethodDecl [commons _]) + (case (get@ #import-member-kind commons) + #StaticIMK + (get@ #import-member-tvars commons) + + _ + (List/append class-tvars (get@ #import-member-tvars commons))) + + _ + class-tvars)) + +(def: (member-def-arg-bindings type-params class member) + (-> (List TypeParam) ClassDecl ImportMemberDecl (Lux [(List AST) (List AST) (List Text) (List AST)])) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (let [(^slots [#import-member-tvars #import-member-args]) commons] + (do Monad + [arg-inputs (mapM @ + (: (-> [Bool GenericType] (Lux [AST AST])) + (lambda [[maybe? _]] + (with-gensyms [arg-name] + (wrap [arg-name (if maybe? + (` (!!! (~ arg-name))) + arg-name)])))) + import-member-args) + #let [arg-classes (: (List Text) + (map (. (simple-class$ (List/append type-params import-member-tvars)) product;right) + import-member-args)) + arg-types (map (: (-> [Bool GenericType] AST) + (lambda [[maybe? arg]] + (let [arg-type (class->type (get@ #import-member-mode commons) type-params arg)] + (if maybe? + (` (Maybe (~ arg-type))) + arg-type)))) + import-member-args) + arg-lambda-inputs (map product;left arg-inputs) + arg-method-inputs (map product;right arg-inputs)]] + (wrap [arg-lambda-inputs arg-method-inputs arg-classes arg-types]))) + + _ + (:: Monad wrap [(list) (list) (list) (list)]))) + +(def: (member-def-return mode type-params class member) + (-> Primitive-Mode (List TypeParam) ClassDecl ImportMemberDecl (Lux AST)) + (case member + (#ConstructorDecl _) + (:: Monad wrap (class-decl-type$ class)) + + (#MethodDecl [_ method]) + (:: Monad wrap (class->type mode type-params (get@ #import-method-return method))) + + _ + (compiler;fail "Only methods have return values."))) + +(def: (decorate-return-maybe member [return-type return-term]) + (-> ImportMemberDecl [AST AST] [AST AST]) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (if (get@ #import-member-maybe? commons) + [(` (Maybe (~ return-type))) + (` (??? (~ return-term)))] + [return-type + (let [g!temp (ast;symbol ["" "Ω"])] + (` (let [(~ g!temp) (~ return-term)] + (if (null? (:! (host (~' java.lang.Object)) + (~ g!temp))) + (error! "Can't produce null references from method calls.") + (~ g!temp)))))]) + + _ + [return-type return-term])) + +(do-template [ ] + [(def: ( member [return-type return-term]) + (-> ImportMemberDecl [AST AST] [AST AST]) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (if (get@ commons) + [ ] + [return-type return-term]) + + _ + [return-type return-term]))] + + [decorate-return-try #import-member-try? (` (Either Text (~ return-type))) (` (try (~ return-term)))] + [decorate-return-io #import-member-io? (` (IO (~ return-type))) (` (io (~ return-term)))] + ) + +(def: (free-type-param? [name bounds]) + (-> TypeParam Bool) + (case bounds + #;Nil true + _ false)) + +(def: (type-param->type-arg [name _]) + (-> TypeParam AST) + (ast;symbol ["" name])) + +(def: (with-mode-output mode output-type body) + (-> Primitive-Mode GenericType AST AST) + (case mode + #ManualPrM + body + + #AutoPrM + (case output-type + (#GenericClass ["byte" _]) + (` (b2l (~ body))) + + (#GenericClass ["short" _]) + (` (s2l (~ body))) + + (#GenericClass ["int" _]) + (` (i2l (~ body))) + + (#GenericClass ["float" _]) + (` (f2d (~ body))) + + _ + body))) + +(def: (auto-conv-class? class) + (-> Text Bool) + (case class + (^or "byte" "short" "int" "float") + true + + _ + false)) + +(def: (auto-conv [class var]) + (-> [Text AST] (List AST)) + (case class + "byte" (list var (` (l2b (~ var)))) + "short" (list var (` (l2s (~ var)))) + "int" (list var (` (l2i (~ var)))) + "float" (list var (` (d2f (~ var)))) + _ (list))) + +(def: (with-mode-inputs mode inputs body) + (-> Primitive-Mode (List [Text AST]) AST AST) + (case mode + #ManualPrM + body + + #AutoPrM + (` (let [(~@ (|> inputs + (List/map auto-conv) + List/join))] + (~ body))))) + +(def: (with-mode-field-get mode class output) + (-> Primitive-Mode GenericType AST AST) + (case mode + #ManualPrM + output + + #AutoPrM + (case (simple-class$ (list) class) + "byte" (` (b2l (~ output))) + "short" (` (s2l (~ output))) + "int" (` (i2l (~ output))) + "float" (` (f2d (~ output))) + _ output))) + +(def: (with-mode-field-set mode class input) + (-> Primitive-Mode GenericType AST AST) + (case mode + #ManualPrM + input + + #AutoPrM + (case (simple-class$ (list) class) + "byte" (` (l2b (~ input))) + "short" (` (l2s (~ input))) + "int" (` (l2i (~ input))) + "float" (` (d2f (~ input))) + _ input))) + +(def: (member-def-interop type-params kind class [arg-lambda-inputs arg-method-inputs arg-classes arg-types] member method-prefix) + (-> (List TypeParam) ClassKind ClassDecl [(List AST) (List AST) (List Text) (List AST)] ImportMemberDecl Text (Lux (List AST))) + (let [[full-name class-tvars] class + all-params (|> (member-type-vars class-tvars member) + (filter free-type-param?) + (map type-param->type-arg))] + (case member + (#EnumDecl enum-members) + (do Monad + [#let [enum-type (: AST + (case class-tvars + #;Nil + (` (host (~ (ast;symbol ["" full-name])))) + + _ + (let [=class-tvars (|> class-tvars + (filter free-type-param?) + (map type-param->type-arg))] + (` (All [(~@ =class-tvars)] (host (~ (ast;symbol ["" full-name])) [(~@ =class-tvars)])))))) + getter-interop (: (-> Text AST) + (lambda [name] + (let [getter-name (ast;symbol ["" (format method-prefix member-separator name)])] + (` (def: (~ getter-name) + (~ enum-type) + (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" name)))] []))))))]] + (wrap (map getter-interop enum-members))) + + (#ConstructorDecl [commons _]) + (do Monad + [return-type (member-def-return (get@ #import-member-mode commons) type-params class member) + #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) + def-params (list (ast;tuple arg-lambda-inputs)) + jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" full-name ":" (text;join-with "," arg-classes))))] + [(~@ arg-method-inputs)])) + (with-mode-inputs (get@ #import-member-mode commons) + (list;zip2 arg-classes arg-lambda-inputs))) + [return-type jvm-interop] (|> [return-type jvm-interop] + (decorate-return-maybe member) + (decorate-return-try member) + (decorate-return-io member))]] + (wrap (list (` (def: ((~ def-name) (~@ def-params)) + (All [(~@ all-params)] (-> [(~@ arg-types)] (~ return-type))) + (~ jvm-interop)))))) + + (#MethodDecl [commons method]) + (with-gensyms [g!obj] + (do @ + [return-type (member-def-return (get@ #import-member-mode commons) type-params class member) + #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) + (^slots [#import-member-kind]) commons + (^slots [#import-method-name]) method + [jvm-op obj-ast class-ast] (: [Text (List AST) (List AST)] + (case import-member-kind + #StaticIMK + ["invokestatic" + (list) + (list)] + + #VirtualIMK + (case kind + #Class + ["invokevirtual" + (list g!obj) + (list (class-decl-type$ class))] + + #Interface + ["invokeinterface" + (list g!obj) + (list (class-decl-type$ class))] + ))) + def-params (#;Cons (ast;tuple arg-lambda-inputs) obj-ast) + def-param-types (#;Cons (` [(~@ arg-types)]) class-ast) + jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format jvm-op ":" full-name ":" import-method-name + ":" (text;join-with "," arg-classes))))] + [(~@ obj-ast) (~@ arg-method-inputs)])) + (with-mode-output (get@ #import-member-mode commons) + (get@ #import-method-return method)) + (with-mode-inputs (get@ #import-member-mode commons) + (list;zip2 arg-classes arg-lambda-inputs))) + [return-type jvm-interop] (|> [return-type jvm-interop] + (decorate-return-maybe member) + (decorate-return-try member) + (decorate-return-io member))]] + (wrap (list (` (def: ((~ def-name) (~@ def-params)) + (All [(~@ all-params)] (-> (~@ def-param-types) (~ return-type))) + (~ jvm-interop))))))) + + (#FieldAccessDecl fad) + (do Monad + [#let [(^open) fad + base-gtype (class->type import-field-mode type-params import-field-type) + g!class (class-decl-type$ class) + g!type (if import-field-maybe? + (` (Maybe (~ base-gtype))) + base-gtype) + tvar-asts (: (List AST) + (|> class-tvars + (filter free-type-param?) + (map type-param->type-arg))) + getter-name (ast;symbol ["" (format method-prefix member-separator import-field-name)]) + setter-name (ast;symbol ["" (format method-prefix member-separator import-field-name "!")])] + getter-interop (with-gensyms [g!obj] + (let [getter-call (if import-field-static? + getter-name + (` ((~ getter-name) (~ g!obj)))) + getter-type (if import-field-setter? + (` (IO (~ g!type))) + g!type) + getter-type (if import-field-static? + getter-type + (` (-> (~ g!class) (~ getter-type)))) + getter-type (` (All [(~@ tvar-asts)] (~ getter-type))) + getter-body (if import-field-static? + (with-mode-field-get import-field-mode import-field-type + (` (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" import-field-name)))] []))) + (with-mode-field-get import-field-mode import-field-type + (` (;_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" full-name ":" import-field-name)))] [(~ g!obj)])))) + getter-body (if import-field-maybe? + (` (??? (~ getter-body))) + getter-body) + getter-body (if import-field-setter? + (` (io (~ getter-body))) + getter-body)] + (wrap (` (def: (~ getter-call) + (~ getter-type) + (~ getter-body)))))) + setter-interop (if import-field-setter? + (with-gensyms [g!obj g!value] + (let [setter-call (if import-field-static? + (` ((~ setter-name) (~ g!value))) + (` ((~ setter-name) (~ g!value) (~ g!obj)))) + setter-type (if import-field-static? + (` (All [(~@ tvar-asts)] (-> (~ g!type) (IO Unit)))) + (` (All [(~@ tvar-asts)] (-> (~ g!type) (~ g!class) (IO Unit))))) + setter-value (with-mode-field-set import-field-mode import-field-type g!value) + setter-value (if import-field-maybe? + (` (!!! (~ setter-value))) + setter-value) + setter-command (format (if import-field-static? "putstatic" "putfield") + ":" full-name ":" import-field-name)] + (wrap (: (List AST) + (list (` (def: (~ setter-call) + (~ setter-type) + (io (;_lux_proc ["jvm" (~ (ast;text setter-command))] + [(~ setter-value)]))))))))) + (wrap (list)))] + (wrap (list& getter-interop setter-interop))) + ))) + +(def: (member-import$ type-params long-name? kind class member) + (-> (List TypeParam) Bool ClassKind ClassDecl ImportMemberDecl (Lux (List AST))) + (let [[full-name _] class + method-prefix (if long-name? + full-name + (short-class-name full-name))] + (do Monad + [=args (member-def-arg-bindings type-params class member)] + (member-def-interop type-params kind class =args member method-prefix)))) + +(def: (interface? class) + (All [a] (-> (host java.lang.Class [a]) Bool)) + (_lux_proc ["jvm" "invokevirtual:java.lang.Class:isInterface:"] [class])) + +(def: (load-class class-name) + (-> Text (Either Text (host java.lang.Class [(Ex [a] a)]))) + (try (_lux_proc ["jvm" "invokestatic:java.lang.Class:forName:java.lang.String"] [class-name]))) + +(def: (class-kind [class-name _]) + (-> ClassDecl (Lux ClassKind)) + (case (load-class class-name) + (#;Right class) + (:: Monad wrap (if (interface? class) + #Interface + #Class)) + + (#;Left _) + (compiler;fail (format "Unknown class: " class-name)))) + +(syntax: #export (jvm-import [#let [imports (class-imports *compiler*)]] + [long-name? (s;this? (' #long))] + [class-decl (class-decl^ imports)] + [#let [full-class-name (product;left class-decl) + imports (add-import [(short-class-name full-class-name) full-class-name] + (class-imports *compiler*))]] + [members (s;some (import-member-decl^ imports (product;right class-decl)))]) + {#;doc (doc "Allows importing JVM classes, and using them as types." + "Their methods, fields and enum options can also be imported." + "Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes." + "Examples:" + (jvm-import java.lang.Object + (new []) + (equals [Object] boolean) + (wait [int] #io #try void)) + "Special options can also be given for the return values." + "#? means that the values will be returned inside a Maybe type. That way, null becomes #;None." + "#try means that the computation might throw an exception, and the return value will be wrapped by the Error type." + "#io means the computation has side effects, and will be wrapped by the IO type." + "These options must show up in the following order [#io #try #?] (although, each option can be used independently)." + (jvm-import java.lang.String + (new [(Array byte)]) + (#static valueOf [char] String) + (#static valueOf #as int-valueOf [int] String)) + + (jvm-import #long (java.util.List e) + (size [] int) + (get [int] e)) + + (jvm-import (java.util.ArrayList a) + ([T] toArray [(Array T)] (Array T))) + "#long makes it so the class-type that is generated is of the fully-qualified name." + "In this case, it avoids a clash between the java.util.List type, and Lux's own List type." + (jvm-import java.lang.Character$UnicodeScript + (#enum ARABIC CYRILLIC LATIN)) + "All enum options to be imported must be specified." + + (jvm-import #long (lux.concurrency.promise.JvmPromise A) + (resolve [A] boolean) + (poll [] A) + (wasResolved [] boolean) + (waitOn [lux.Function] void) + (#static [A] make [A] (JvmPromise A))) + "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters." + "Lux types, such as Maybe can't be named (otherwise, they'd be confused for Java classes)." + + "Also, the names of the imported members will look like ClassName.MemberName." + "E.g.:" + (Object.new []) + (Object.equals [other-object] my-object) + (java.util.List.size [] my-list) + Character$UnicodeScript.LATIN + )} + (do Monad + [kind (class-kind class-decl) + =members (mapM @ (member-import$ (product;right class-decl) long-name? kind class-decl) members)] + (wrap (list& (class-import$ long-name? class-decl) (List/join =members))))) + +(syntax: #export (array [#let [imports (class-imports *compiler*)]] + [type (generic-type^ imports (list))] + size) + {#;doc (doc "Create an array of the given type, with the given size." + (array Object +10))} + (case type + (^template [ ] + (^ (#GenericClass (list))) + (wrap (list (` (;_lux_proc ["jvm" ] [(~ size)]))))) + (["boolean" "znewarray"] + ["byte" "bnewarray"] + ["short" "snewarray"] + ["int" "inewarray"] + ["long" "lnewarray"] + ["float" "fnewarray"] + ["double" "dnewarray"] + ["char" "cnewarray"]) + + _ + (wrap (list (` (;_lux_proc ["jvm" "anewarray"] [(~ (ast;text (generic-type$ type))) (~ size)])))))) + +(syntax: #export (array-length array) + {#;doc (doc "Gives the length of an array." + (array-length my-array))} + (wrap (list (` (;_lux_proc ["jvm" "arraylength"] [(~ array)]))))) + +(def: (type->class-name type) + (-> Type (Lux Text)) + (case type + (#;HostT name params) + (:: Monad wrap name) + + (#;AppT F A) + (case (type;apply-type F A) + #;None + (compiler;fail (format "Can't apply type: " (type;to-text F) " to " (type;to-text A))) + + (#;Some type') + (type->class-name type')) + + (#;NamedT _ type') + (type->class-name type') + + #;UnitT + (:: Monad wrap "java.lang.Object") + + (^or #;VoidT (#;VarT _) (#;ExT _) (#;BoundT _) (#;SumT _) (#;ProdT _) (#;LambdaT _) (#;UnivQ _) (#;ExQ _)) + (compiler;fail (format "Can't convert to JvmType: " (type;to-text type))) + )) + +(syntax: #export (array-load idx array) + {#;doc (doc "Loads an element from an array." + (array-load 10 my-array))} + (case array + [_ (#;SymbolS array-name)] + (do Monad + [array-type (compiler;find-type array-name) + array-jvm-type (type->class-name array-type)] + (case array-jvm-type + (^template [ ] + + (wrap (list (` (;_lux_proc ["jvm" ] [(~ array) (~ idx)]))))) + (["[Z" "zaload"] + ["[B" "baload"] + ["[S" "saload"] + ["[I" "iaload"] + ["[J" "jaload"] + ["[F" "faload"] + ["[D" "daload"] + ["[C" "caload"]) + + _ + (wrap (list (` (;_lux_proc ["jvm" "aaload"] [(~ array) (~ idx)])))))) + + _ + (with-gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (;;array-load (~ g!array) (~ idx))))))))) + +(syntax: #export (array-store idx value array) + {#;doc (doc "Stores an element into an array." + (array-store 10 my-object my-array))} + (case array + [_ (#;SymbolS array-name)] + (do Monad + [array-type (compiler;find-type array-name) + array-jvm-type (type->class-name array-type)] + (case array-jvm-type + (^template [ ] + + (wrap (list (` (;_lux_proc ["jvm" ] [(~ array) (~ idx) (~ value)]))))) + (["[Z" "zastore"] + ["[B" "bastore"] + ["[S" "sastore"] + ["[I" "iastore"] + ["[J" "jastore"] + ["[F" "fastore"] + ["[D" "dastore"] + ["[C" "castore"]) + + _ + (wrap (list (` (;_lux_proc ["jvm" "aastore"] [(~ array) (~ idx) (~ value)])))))) + + _ + (with-gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (;;array-store (~ g!array) (~ idx) (~ value))))))))) + +(def: simple-bindings^ + (Syntax (List [Text AST])) + (s;tuple (s;some (s;seq s;local-symbol s;any)))) + +(syntax: #export (with-open [bindings simple-bindings^] body) + {#;doc (doc "Creates a local-binding with the desired resources, and runs the body (assumed to be in the IO type)." + "Afterwards, closes all resources (assumed to be subclasses of java.io.Closeable), and returns the value resulting from running the body." + (with-open [my-res1 (res1-constructor ...) + my-res2 (res1-constructor ...)] + (do Monad + [foo (do-something my-res1) + bar (do-something-else my-res2)] + (do-one-last-thing foo bar))))} + (with-gensyms [g!output g!_] + (let [inits (List/join (List/map (lambda [[res-name res-ctor]] + (list (ast;symbol ["" res-name]) res-ctor)) + bindings)) + closes (List/map (lambda [res] + (` (try (;_lux_proc ["jvm" "invokevirtual:java.io.Closeable:close:"] + [(~ (ast;symbol ["" (product;left res)]))])))) + bindings)] + (wrap (list (` (do Monad + [(~@ inits) + (~ g!output) (~ body) + (~' #let) [(~ g!_) (exec (~@ (reverse closes)) [])]] + ((~' wrap) (~ g!output))))))))) + +(syntax: #export (class-for [#let [imports (class-imports *compiler*)]] + [type (generic-type^ imports (list))]) + {#;doc (doc "Loads the class as a java.lang.Class object." + (class-for java.lang.String))} + (wrap (list (` (;_lux_proc ["jvm" "load-class"] [(~ (ast;text (simple-class$ (list) type)))]))))) + +(def: get-compiler + (Lux Compiler) + (lambda [compiler] + (#;Right [compiler compiler]))) + +(def: (fully-qualify-class-name+ imports name) + (-> ClassImports Text (Maybe Text)) + (cond (fully-qualified-class-name? name) + (#;Some name) + + (member? text;Eq java.lang-classes name) + (#;Some (format "java.lang." name)) + + ## else + (get-import name imports))) + +(def: #export (resolve-class class) + {#;doc (doc "Given a potentially unqualified class name, qualifies it if necessary." + (resolve-class "String") + => + "java.lang.String")} + (-> Text (Lux Text)) + (do Monad + [*compiler* get-compiler] + (case (fully-qualify-class-name+ (class-imports *compiler*) class) + (#;Some fqcn) + (wrap fqcn) + + #;None + (compiler;fail (Text/append "Unknown class: " class))))) diff --git a/stdlib/source/lux/host.lux b/stdlib/source/lux/host.lux deleted file mode 100644 index 41d567165..000000000 --- a/stdlib/source/lux/host.lux +++ /dev/null @@ -1,2169 +0,0 @@ -(;module: - lux - (lux (control monad - [enum]) - [io #+ IO Monad io] - (codata function) - (data (coll [list #* "" Functor Fold "List/" Monad Monoid] - [array #+ Array]) - number - maybe - [product] - [text "Text/" Eq Monoid] - text/format - [bool "Bool/" Codec]) - [compiler #+ with-gensyms Functor Monad] - (macro [ast] - ["s" syntax #+ syntax: Syntax]) - [type] - )) - -(do-template [ ] - [(def: #export ( value) - {#;doc (doc "Type converter." - "From:" - - "To:" - )} - (-> (host ) (host )) - (_lux_proc ["jvm" ] [value]))] - - [b2l "b2l" java.lang.Byte java.lang.Long] - - [s2l "s2l" java.lang.Short java.lang.Long] - - [d2i "d2i" java.lang.Double java.lang.Integer] - [d2l "d2l" java.lang.Double java.lang.Long] - [d2f "d2f" java.lang.Double java.lang.Float] - - [f2i "f2i" java.lang.Float java.lang.Integer] - [f2l "f2l" java.lang.Float java.lang.Long] - [f2d "f2d" java.lang.Float java.lang.Double] - - [i2b "i2b" java.lang.Integer java.lang.Byte] - [i2s "i2s" java.lang.Integer java.lang.Short] - [i2l "i2l" java.lang.Integer java.lang.Long] - [i2f "i2f" java.lang.Integer java.lang.Float] - [i2d "i2d" java.lang.Integer java.lang.Double] - [i2c "i2c" java.lang.Integer java.lang.Character] - - [l2b "l2b" java.lang.Long java.lang.Byte] - [l2s "l2s" java.lang.Long java.lang.Short] - [l2i "l2i" java.lang.Long java.lang.Integer] - [l2f "l2f" java.lang.Long java.lang.Float] - [l2d "l2d" java.lang.Long java.lang.Double] - - [c2b "c2b" java.lang.Character java.lang.Byte] - [c2s "c2s" java.lang.Character java.lang.Short] - [c2i "c2i" java.lang.Character java.lang.Integer] - [c2l "c2l" java.lang.Character java.lang.Long] - ) - -## [Utils] -(def: array-type-name "#Array") -(def: constructor-method-name "") -(def: member-separator ".") - -## Types -(do-template [ ] - [(type: #export - (#;HostT #;Nil))] - - ["[Z" Boolean-Array] - ["[B" Byte-Array] - ["[S" Short-Array] - ["[I" Int-Array] - ["[J" Long-Array] - ["[F" Float-Array] - ["[D" Double-Array] - ["[C" Char-Array] - ) - -(type: Code Text) - -(type: BoundKind - #UpperBound - #LowerBound) - -(type: #rec GenericType - (#GenericTypeVar Text) - (#GenericClass [Text (List GenericType)]) - (#GenericArray GenericType) - (#GenericWildcard (Maybe [BoundKind GenericType]))) - -(type: TypeParam - [Text (List GenericType)]) - -(type: Primitive-Mode - #ManualPrM - #AutoPrM) - -(type: PrivacyModifier - #PublicPM - #PrivatePM - #ProtectedPM - #DefaultPM) - -(type: StateModifier - #VolatileSM - #FinalSM - #DefaultSM) - -(type: InheritanceModifier - #FinalIM - #AbstractIM - #DefaultIM) - -(type: ClassKind - #Class - #Interface) - -(type: ClassDecl - {#class-name Text - #class-params (List TypeParam)}) - -(type: StackFrame (host java.lang.StackTraceElement)) -(type: StackTrace (Array StackFrame)) - -(type: SuperClassDecl - {#super-class-name Text - #super-class-params (List GenericType)}) - -(type: AnnotationParam - [Text AST]) - -(type: Annotation - {#ann-name Text - #ann-params (List AnnotationParam)}) - -(type: MemberDecl - {#member-name Text - #member-privacy PrivacyModifier - #member-anns (List Annotation)}) - -(type: FieldDecl - (#ConstantField GenericType AST) - (#VariableField StateModifier GenericType)) - -(type: MethodDecl - {#method-tvars (List TypeParam) - #method-inputs (List GenericType) - #method-output GenericType - #method-exs (List GenericType)}) - -(type: ArgDecl - {#arg-name Text - #arg-type GenericType}) - -(type: ConstructorArg - [GenericType AST]) - -(type: MethodDef - (#ConstructorMethod [Bool - (List TypeParam) - (List ArgDecl) - (List ConstructorArg) - AST - (List GenericType)]) - (#VirtualMethod [Bool - Bool - (List TypeParam) - (List ArgDecl) - GenericType - AST - (List GenericType)]) - (#OverridenMethod [Bool - ClassDecl - (List TypeParam) - (List ArgDecl) - GenericType - AST - (List GenericType)]) - (#StaticMethod [Bool - (List TypeParam) - (List ArgDecl) - GenericType - AST - (List GenericType)]) - (#AbstractMethod [(List TypeParam) - (List ArgDecl) - GenericType - (List GenericType)]) - (#NativeMethod [(List TypeParam) - (List ArgDecl) - GenericType - (List GenericType)])) - -(type: PartialCall - {#pc-method AST - #pc-args AST}) - -(type: ImportMethodKind - #StaticIMK - #VirtualIMK) - -(type: ImportMethodCommons - {#import-member-mode Primitive-Mode - #import-member-alias Text - #import-member-kind ImportMethodKind - #import-member-tvars (List TypeParam) - #import-member-args (List [Bool GenericType]) - #import-member-maybe? Bool - #import-member-try? Bool - #import-member-io? Bool}) - -(type: ImportConstructorDecl - {}) - -(type: ImportMethodDecl - {#import-method-name Text - #import-method-return GenericType}) - -(type: ImportFieldDecl - {#import-field-mode Primitive-Mode - #import-field-name Text - #import-field-static? Bool - #import-field-maybe? Bool - #import-field-setter? Bool - #import-field-type GenericType}) - -(type: ImportMemberDecl - (#EnumDecl (List Text)) - (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) - (#MethodDecl [ImportMethodCommons ImportMethodDecl]) - (#FieldAccessDecl ImportFieldDecl)) - -(type: ClassImports - (List [Text Text])) - -## Utils -(def: (short-class-name name) - (-> Text Text) - (case (reverse (text;split-all-with "." name)) - (#;Cons short-name _) - short-name - - #;Nil - name)) - -(def: (manual-primitive-to-type class) - (-> Text (Maybe AST)) - (case class - (^template [ ] - - (#;Some (' ))) - (["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)] - ["void" ;Unit]) - - _ - #;None)) - -(def: (auto-primitive-to-type class) - (-> Text (Maybe AST)) - (case class - (^template [ ] - - (#;Some (' ))) - (["boolean" ;Bool] - ["byte" ;Int] - ["short" ;Int] - ["int" ;Int] - ["long" ;Int] - ["float" ;Real] - ["double" ;Real] - ["char" ;Char] - ["void" ;Unit]) - - _ - #;None)) - -(def: (generic-class->type' mode type-params in-array? name+params - class->type') - (-> Primitive-Mode (List TypeParam) Bool [Text (List GenericType)] - (-> Primitive-Mode (List TypeParam) Bool GenericType AST) - AST) - (case [name+params mode in-array?] - (^=> [[prim #;Nil] #ManualPrM false] - [(manual-primitive-to-type prim) (#;Some output)]) - output - - (^=> [[prim #;Nil] #AutoPrM false] - [(auto-primitive-to-type prim) (#;Some output)]) - output - - [[name params] _ _] - (let [=params (map (class->type' mode type-params in-array?) params)] - (` (host (~ (ast;symbol ["" name])) [(~@ =params)]))))) - -(def: (class->type' mode type-params in-array? class) - (-> Primitive-Mode (List TypeParam) Bool GenericType AST) - (case class - (#GenericTypeVar name) - (case (find (lambda [[pname pbounds]] - (and (Text/= name pname) - (not (list;empty? pbounds)))) - type-params) - #;None - (ast;symbol ["" name]) - - (#;Some [pname pbounds]) - (class->type' mode type-params in-array? (default (undefined) (list;head pbounds)))) - - (#GenericClass name+params) - (generic-class->type' mode type-params in-array? name+params - class->type') - - (#GenericArray param) - (let [=param (class->type' mode type-params true param)] - (` (host (~ (ast;symbol ["" array-type-name])) [(~ =param)]))) - - (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _]))) - (' (;Ex [*] *)) - - (#GenericWildcard (#;Some [#UpperBound upper-bound])) - (class->type' mode type-params in-array? upper-bound) - )) - -(def: (class->type mode type-params class) - (-> Primitive-Mode (List TypeParam) GenericType AST) - (class->type' mode type-params false class)) - -(def: (type-param-type$ [name bounds]) - (-> TypeParam AST) - (ast;symbol ["" name])) - -(def: (class-decl-type$ (^slots [#class-name #class-params])) - (-> ClassDecl AST) - (let [=params (map (: (-> TypeParam AST) - (lambda [[pname pbounds]] - (case pbounds - #;Nil - (ast;symbol ["" pname]) - - (#;Cons bound1 _) - (class->type #ManualPrM class-params bound1)))) - class-params)] - (` (host (~ (ast;symbol ["" class-name])) [(~@ =params)])))) - -(def: (stack-trace->text trace) - (-> StackTrace Text) - (let [size (_lux_proc ["jvm" "arraylength"] [trace]) - idxs (list;n.range +0 (n.dec size))] - (|> idxs - (map (: (-> Nat Text) - (lambda [idx] - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] - [(_lux_proc ["jvm" "aaload"] [trace idx])])))) - (text;join-with "\n") - ))) - -(def: (get-stack-trace t) - (-> (host java.lang.Throwable) StackTrace) - (_lux_proc ["jvm" "invokevirtual:java.lang.Throwable:getStackTrace:"] [t])) - -(def: #hidden (throwable->text t) - (All [a] (-> (host java.lang.Throwable) (Either Text a))) - (#;Left (format (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [t]) - "\n" - (|> t get-stack-trace stack-trace->text)))) - -(def: empty-imports - ClassImports - (list)) - -(def: (get-import name imports) - (-> Text ClassImports (Maybe Text)) - (:: Functor map product;right - (find (|>. product;left (Text/= name)) - imports))) - -(def: (add-import short+full imports) - (-> [Text Text] ClassImports ClassImports) - (#;Cons short+full imports)) - -(def: (class-imports compiler) - (-> Compiler ClassImports) - (case (compiler;run compiler - (: (Lux ClassImports) - (do Monad - [current-module compiler;current-module-name - defs (compiler;defs current-module)] - (wrap (fold (: (-> [Text Def] ClassImports ClassImports) - (lambda [[short-name [_ meta _]] imports] - (case (compiler;get-text-ann (ident-for #;;jvm-class) meta) - (#;Some full-class-name) - (add-import [short-name full-class-name] imports) - - _ - imports))) - empty-imports - defs))))) - (#;Left _) (list) - (#;Right imports) imports)) - -(def: java.lang-classes - (List Text) - (list ## Interfaces - "Appendable" - "AutoCloseable" - "CharSequence" - "Cloneable" - "Comparable" - "Iterable" - "Readable" - "Runnable" - - ## Classes - "Boolean" - "Byte" - "Character" - "Class" - "ClassLoader" - "ClassValue" - "Compiler" - "Double" - "Enum" - "Float" - "InheritableThreadLocal" - "Integer" - "Long" - "Math" - "Number" - "Object" - "Package" - "Process" - "ProcessBuilder" - "Runtime" - "RuntimePermission" - "SecurityManager" - "Short" - "StackTraceElement" - "StrictMath" - "String" - "StringBuffer" - "StringBuilder" - "System" - "Thread" - "ThreadGroup" - "ThreadLocal" - "Throwable" - "Void" - - ## Exceptions - "ArithmeticException" - "ArrayIndexOutOfBoundsException" - "ArrayStoreException" - "ClassCastException" - "ClassNotFoundException" - "CloneNotSupportedException" - "EnumConstantNotPresentException" - "Exception" - "IllegalAccessException" - "IllegalArgumentException" - "IllegalMonitorStateException" - "IllegalStateException" - "IllegalThreadStateException" - "IndexOutOfBoundsException" - "InstantiationException" - "InterruptedException" - "NegativeArraySizeException" - "NoSuchFieldException" - "NoSuchMethodException" - "NullPointerException" - "NumberFormatException" - "ReflectiveOperationException" - "RuntimeException" - "SecurityException" - "StringIndexOutOfBoundsException" - "TypeNotPresentException" - "UnsupportedOperationException" - - ## Annotations - "Deprecated" - "Override" - "SafeVarargs" - "SuppressWarnings")) - -(def: (fully-qualified-class-name? name) - (-> Text Bool) - (text;contains? "." name)) - -(def: (fully-qualify-class-name imports name) - (-> ClassImports Text Text) - (cond (fully-qualified-class-name? name) - name - - (member? text;Eq java.lang-classes name) - (format "java.lang." name) - - ## else - (default name (get-import name imports)))) - -(def: type-var-class Text "java.lang.Object") - -(def: (simple-class$ params class) - (-> (List TypeParam) GenericType Text) - (case class - (#GenericTypeVar name) - (case (find (lambda [[pname pbounds]] - (and (Text/= name pname) - (not (list;empty? pbounds)))) - params) - #;None - type-var-class - - (#;Some [pname pbounds]) - (simple-class$ params (default (undefined) (list;head pbounds)))) - - (^or (#GenericWildcard #;None) (#GenericWildcard (#;Some [#LowerBound _]))) - type-var-class - - (#GenericWildcard (#;Some [#UpperBound upper-bound])) - (simple-class$ params upper-bound) - - (#GenericClass name params) - name - - (#GenericArray param') - (case param' - (#GenericArray param) - (format "[" (simple-class$ params param)) - - (^template [ ] - (#GenericClass #;Nil) - ) - (["boolean" "[Z"] - ["byte" "[B"] - ["short" "[S"] - ["int" "[I"] - ["long" "[J"] - ["float" "[F"] - ["double" "[D"] - ["char" "[C"]) - - param - (format "[L" (simple-class$ params param) ";")) - )) - -(def: (make-get-const-parser class-name field-name) - (-> Text Text (Syntax AST)) - (do s;Monad - [#let [dotted-name (format "." field-name)] - _ (s;this! (ast;symbol ["" dotted-name]))] - (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" class-name ":" field-name)))] []))))) - -(def: (make-get-var-parser class-name field-name) - (-> Text Text (Syntax AST)) - (do s;Monad - [#let [dotted-name (format "." field-name)] - _ (s;this! (ast;symbol ["" dotted-name]))] - (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" class-name ":" field-name)))] [_jvm_this]))))) - -(def: (make-put-var-parser class-name field-name) - (-> Text Text (Syntax AST)) - (do s;Monad - [#let [dotted-name (format "." field-name)] - [_ _ value] (: (Syntax [Unit Unit AST]) - (s;form ($_ s;seq (s;this! (' :=)) (s;this! (ast;symbol ["" dotted-name])) s;any)))] - (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "putfield" ":" class-name ":" field-name)))] [_jvm_this (~ value)]))))) - -(def: (pre-walk-replace f input) - (-> (-> AST AST) AST AST) - (case (f input) - (^template [] - [meta ( parts)] - [meta ( (map (pre-walk-replace f) parts))]) - ([#;FormS] - [#;TupleS]) - - [meta (#;RecordS pairs)] - [meta (#;RecordS (map (: (-> [AST AST] [AST AST]) - (lambda [[key val]] - [(pre-walk-replace f key) (pre-walk-replace f val)])) - pairs))] - - ast' - ast')) - -(def: (parser->replacer p ast) - (-> (Syntax AST) (-> AST AST)) - (case (s;run (list ast) p) - (#;Right [#;Nil ast']) - ast' - - _ - ast - )) - -(def: (field->parser class-name [[field-name _ _] field]) - (-> Text [MemberDecl FieldDecl] (Syntax AST)) - (case field - (#ConstantField _) - (make-get-const-parser class-name field-name) - - (#VariableField _) - (s;either (make-get-var-parser class-name field-name) - (make-put-var-parser class-name field-name)))) - -(def: (make-constructor-parser params class-name arg-decls) - (-> (List TypeParam) Text (List ArgDecl) (Syntax AST)) - (do s;Monad - [[_ args] (: (Syntax [Unit (List AST)]) - (s;form ($_ s;seq (s;this! (' .new!)) (s;tuple (s;exactly (list;size arg-decls) s;any))))) - #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] - (wrap (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" class-name ":" (text;join-with "," arg-decls'))))] - [(~@ args)]))))) - -(def: (make-static-method-parser params class-name method-name arg-decls) - (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST)) - (do s;Monad - [#let [dotted-name (format "." method-name "!")] - [_ args] (: (Syntax [Unit (List AST)]) - (s;form ($_ s;seq (s;this! (ast;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any))))) - #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] - (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokestatic" ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] - [(~@ args)]))))) - -(do-template [ ] - [(def: ( params class-name method-name arg-decls) - (-> (List TypeParam) Text Text (List ArgDecl) (Syntax AST)) - (do s;Monad - [#let [dotted-name (format "." method-name "!")] - [_ args] (: (Syntax [Unit (List AST)]) - (s;form ($_ s;seq (s;this! (ast;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any))))) - #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] - (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] - [(~' _jvm_this) (~@ args)])))))] - - [make-special-method-parser "invokespecial"] - [make-virtual-method-parser "invokevirtual"] - ) - -(def: (method->parser params class-name [[method-name _ _] meth-def]) - (-> (List TypeParam) Text [MemberDecl MethodDef] (Syntax AST)) - (case meth-def - (#ConstructorMethod strict? type-vars args constructor-args return-expr exs) - (make-constructor-parser params class-name args) - - (#StaticMethod strict? type-vars args return-type return-expr exs) - (make-static-method-parser params class-name method-name args) - - (^or (#VirtualMethod final? strict? type-vars args return-type return-expr exs) (#OverridenMethod strict? owner-class type-vars args return-type return-expr exs)) - (make-special-method-parser params class-name method-name args) - - (#AbstractMethod type-vars args return-type exs) - (make-virtual-method-parser params class-name method-name args) - - (#NativeMethod type-vars args return-type exs) - (make-virtual-method-parser params class-name method-name args))) - -## Syntaxs -(def: (full-class-name^ imports) - (-> ClassImports (Syntax Text)) - (do s;Monad - [name s;local-symbol] - (wrap (fully-qualify-class-name imports name)))) - -(def: privacy-modifier^ - (Syntax PrivacyModifier) - (let [(^open) s;Monad] - ($_ s;alt - (s;this! (' #public)) - (s;this! (' #private)) - (s;this! (' #protected)) - (wrap [])))) - -(def: inheritance-modifier^ - (Syntax InheritanceModifier) - (let [(^open) s;Monad] - ($_ s;alt - (s;this! (' #final)) - (s;this! (' #abstract)) - (wrap [])))) - -(def: bound-kind^ - (Syntax BoundKind) - (s;alt (s;this! (' <)) - (s;this! (' >)))) - -(def: (generic-type^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax GenericType)) - ($_ s;either - (do s;Monad - [_ (s;this! (' ?))] - (wrap (#GenericWildcard #;None))) - (s;tuple (do s;Monad - [_ (s;this! (' ?)) - bound-kind bound-kind^ - bound (generic-type^ imports type-vars)] - (wrap (#GenericWildcard (#;Some [bound-kind bound]))))) - (do s;Monad - [name (full-class-name^ imports)] - (let% [ (do-template [ ] - [(Text/= name) - (wrap (#GenericClass (list)))] - - ["[Z" "Boolean-Array"] - ["[B" "Byte-Array"] - ["[S" "Short-Array"] - ["[I" "Int-Array"] - ["[J" "Long-Array"] - ["[F" "Float-Array"] - ["[D" "Double-Array"] - ["[C" "Char-Array"])] - (cond (member? text;Eq (map product;left type-vars) name) - (wrap (#GenericTypeVar name)) - - - - ## else - (wrap (#GenericClass name (list)))))) - (s;form (do s;Monad - [name (s;this! (' Array)) - component (generic-type^ imports type-vars)] - (case component - (^template [ ] - (#GenericClass #;Nil) - (wrap (#GenericClass (list)))) - (["[Z" "boolean"] - ["[B" "byte"] - ["[S" "short"] - ["[I" "int"] - ["[J" "long"] - ["[F" "float"] - ["[D" "double"] - ["[C" "char"]) - - _ - (wrap (#GenericArray component))))) - (s;form (do s;Monad - [name (full-class-name^ imports) - params (s;some (generic-type^ imports type-vars)) - _ (s;assert (format name " can't be a type-parameter!") - (not (member? text;Eq (map product;left type-vars) name)))] - (wrap (#GenericClass name params)))) - )) - -(def: (type-param^ imports) - (-> ClassImports (Syntax TypeParam)) - (s;either (do s;Monad - [param-name s;local-symbol] - (wrap [param-name (list)])) - (s;tuple (do s;Monad - [param-name s;local-symbol - _ (s;this! (' <)) - bounds (s;many (generic-type^ imports (list)))] - (wrap [param-name bounds]))))) - -(def: (type-params^ imports) - (-> ClassImports (Syntax (List TypeParam))) - (s;tuple (s;some (type-param^ imports)))) - -(def: (class-decl^ imports) - (-> ClassImports (Syntax ClassDecl)) - (s;either (do s;Monad - [name (full-class-name^ imports)] - (wrap [name (list)])) - (s;form (do s;Monad - [name (full-class-name^ imports) - params (s;some (type-param^ imports))] - (wrap [name params]))) - )) - -(def: (super-class-decl^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax SuperClassDecl)) - (s;either (do s;Monad - [name (full-class-name^ imports)] - (wrap [name (list)])) - (s;form (do s;Monad - [name (full-class-name^ imports) - params (s;some (generic-type^ imports type-vars))] - (wrap [name params]))))) - -(def: annotation-params^ - (Syntax (List AnnotationParam)) - (s;record (s;some (s;seq s;local-tag s;any)))) - -(def: (annotation^ imports) - (-> ClassImports (Syntax Annotation)) - (s;either (do s;Monad - [ann-name (full-class-name^ imports)] - (wrap [ann-name (list)])) - (s;form (s;seq (full-class-name^ imports) - annotation-params^)))) - -(def: (annotations^' imports) - (-> ClassImports (Syntax (List Annotation))) - (do s;Monad - [_ (s;this! (' #ann))] - (s;tuple (s;some (annotation^ imports))))) - -(def: (annotations^ imports) - (-> ClassImports (Syntax (List Annotation))) - (do s;Monad - [anns?? (s;opt (annotations^' imports))] - (wrap (default (list) anns??)))) - -(def: (throws-decl'^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax (List GenericType))) - (do s;Monad - [_ (s;this! (' #throws))] - (s;tuple (s;some (generic-type^ imports type-vars))))) - -(def: (throws-decl^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax (List GenericType))) - (do s;Monad - [exs? (s;opt (throws-decl'^ imports type-vars))] - (wrap (default (list) exs?)))) - -(def: (method-decl^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDecl])) - (s;form (do s;Monad - [tvars (s;default (list) (type-params^ imports)) - name s;local-symbol - anns (annotations^ imports) - inputs (s;tuple (s;some (generic-type^ imports type-vars))) - output (generic-type^ imports type-vars) - exs (throws-decl^ imports type-vars)] - (wrap [[name #PublicPM anns] {#method-tvars tvars - #method-inputs inputs - #method-output output - #method-exs exs}])))) - -(def: state-modifier^ - (Syntax StateModifier) - ($_ s;alt - (s;this! (' #volatile)) - (s;this! (' #final)) - (:: s;Monad wrap []))) - -(def: (field-decl^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax [MemberDecl FieldDecl])) - (s;either (s;form (do s;Monad - [_ (s;this! (' #const)) - name s;local-symbol - anns (annotations^ imports) - type (generic-type^ imports type-vars) - body s;any] - (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) - (s;form (do s;Monad - [pm privacy-modifier^ - sm state-modifier^ - name s;local-symbol - anns (annotations^ imports) - type (generic-type^ imports type-vars)] - (wrap [[name pm anns] (#VariableField [sm type])]))))) - -(def: (arg-decl^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax ArgDecl)) - (s;tuple (s;seq s;local-symbol - (generic-type^ imports type-vars)))) - -(def: (arg-decls^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax (List ArgDecl))) - (s;some (arg-decl^ imports type-vars))) - -(def: (constructor-arg^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax ConstructorArg)) - (s;tuple (s;seq (generic-type^ imports type-vars) s;any))) - -(def: (constructor-args^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax (List ConstructorArg))) - (s;tuple (s;some (constructor-arg^ imports type-vars)))) - -(def: (constructor-method^ imports class-vars) - (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) - (s;form (do s;Monad - [pm privacy-modifier^ - strict-fp? (s;this? (' #strict)) - method-vars (s;default (list) (type-params^ imports)) - #let [total-vars (List/append class-vars method-vars)] - [_ arg-decls] (s;form (s;seq (s;this! (' new)) - (arg-decls^ imports total-vars))) - constructor-args (constructor-args^ imports total-vars) - exs (throws-decl^ imports total-vars) - annotations (annotations^ imports) - body s;any] - (wrap [{#member-name constructor-method-name - #member-privacy pm - #member-anns annotations} - (#ConstructorMethod strict-fp? method-vars arg-decls constructor-args body exs)])))) - -(def: (virtual-method-def^ imports class-vars) - (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) - (s;form (do s;Monad - [pm privacy-modifier^ - strict-fp? (s;this? (' #strict)) - final? (s;this? (' #final)) - method-vars (s;default (list) (type-params^ imports)) - #let [total-vars (List/append class-vars method-vars)] - [name arg-decls] (s;form (s;seq s;local-symbol - (arg-decls^ imports total-vars))) - return-type (generic-type^ imports total-vars) - exs (throws-decl^ imports total-vars) - annotations (annotations^ imports) - body s;any] - (wrap [{#member-name name - #member-privacy pm - #member-anns annotations} - (#VirtualMethod final? strict-fp? method-vars arg-decls return-type body exs)])))) - -(def: (overriden-method-def^ imports) - (-> ClassImports (Syntax [MemberDecl MethodDef])) - (s;form (do s;Monad - [strict-fp? (s;this? (' #strict)) - owner-class (class-decl^ imports) - method-vars (s;default (list) (type-params^ imports)) - #let [total-vars (List/append (product;right owner-class) method-vars)] - [name arg-decls] (s;form (s;seq s;local-symbol - (arg-decls^ imports total-vars))) - return-type (generic-type^ imports total-vars) - exs (throws-decl^ imports total-vars) - annotations (annotations^ imports) - body s;any] - (wrap [{#member-name name - #member-privacy #PublicPM - #member-anns annotations} - (#OverridenMethod strict-fp? owner-class method-vars arg-decls return-type body exs)])))) - -(def: (static-method-def^ imports) - (-> ClassImports (Syntax [MemberDecl MethodDef])) - (s;form (do s;Monad - [pm privacy-modifier^ - strict-fp? (s;this? (' #strict)) - _ (s;this! (' #static)) - method-vars (s;default (list) (type-params^ imports)) - #let [total-vars method-vars] - [name arg-decls] (s;form (s;seq s;local-symbol - (arg-decls^ imports total-vars))) - return-type (generic-type^ imports total-vars) - exs (throws-decl^ imports total-vars) - annotations (annotations^ imports) - body s;any] - (wrap [{#member-name name - #member-privacy pm - #member-anns annotations} - (#StaticMethod strict-fp? method-vars arg-decls return-type body exs)])))) - -(def: (abstract-method-def^ imports) - (-> ClassImports (Syntax [MemberDecl MethodDef])) - (s;form (do s;Monad - [pm privacy-modifier^ - _ (s;this! (' #abstract)) - method-vars (s;default (list) (type-params^ imports)) - #let [total-vars method-vars] - [name arg-decls] (s;form (s;seq s;local-symbol - (arg-decls^ imports total-vars))) - return-type (generic-type^ imports total-vars) - exs (throws-decl^ imports total-vars) - annotations (annotations^ imports)] - (wrap [{#member-name name - #member-privacy pm - #member-anns annotations} - (#AbstractMethod method-vars arg-decls return-type exs)])))) - -(def: (native-method-def^ imports) - (-> ClassImports (Syntax [MemberDecl MethodDef])) - (s;form (do s;Monad - [pm privacy-modifier^ - _ (s;this! (' #native)) - method-vars (s;default (list) (type-params^ imports)) - #let [total-vars method-vars] - [name arg-decls] (s;form (s;seq s;local-symbol - (arg-decls^ imports total-vars))) - return-type (generic-type^ imports total-vars) - exs (throws-decl^ imports total-vars) - annotations (annotations^ imports)] - (wrap [{#member-name name - #member-privacy pm - #member-anns annotations} - (#NativeMethod method-vars arg-decls return-type exs)])))) - -(def: (method-def^ imports class-vars) - (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) - ($_ s;either - (constructor-method^ imports class-vars) - (virtual-method-def^ imports class-vars) - (overriden-method-def^ imports) - (static-method-def^ imports) - (abstract-method-def^ imports) - (native-method-def^ imports))) - -(def: partial-call^ - (Syntax PartialCall) - (s;form (s;seq s;any s;any))) - -(def: class-kind^ - (Syntax ClassKind) - (s;either (do s;Monad - [_ (s;this! (' #class))] - (wrap #Class)) - (do s;Monad - [_ (s;this! (' #interface))] - (wrap #Interface)) - )) - -(def: import-member-alias^ - (Syntax (Maybe Text)) - (s;opt (do s;Monad - [_ (s;this! (' #as))] - s;local-symbol))) - -(def: (import-member-args^ imports type-vars) - (-> ClassImports (List TypeParam) (Syntax (List [Bool GenericType]))) - (s;tuple (s;some (s;seq (s;this? (' #?)) (generic-type^ imports type-vars))))) - -(def: import-member-return-flags^ - (Syntax [Bool Bool Bool]) - ($_ s;seq (s;this? (' #io)) (s;this? (' #try)) (s;this? (' #?)))) - -(def: primitive-mode^ - (Syntax Primitive-Mode) - (s;alt (s;this! (' #manual)) - (s;this! (' #auto)))) - -(def: (import-member-decl^ imports owner-vars) - (-> ClassImports (List TypeParam) (Syntax ImportMemberDecl)) - ($_ s;either - (s;form (do s;Monad - [_ (s;this! (' #enum)) - enum-members (s;some s;local-symbol)] - (wrap (#EnumDecl enum-members)))) - (s;form (do s;Monad - [tvars (s;default (list) (type-params^ imports)) - _ (s;this! (' new)) - ?alias import-member-alias^ - #let [total-vars (List/append owner-vars tvars)] - ?prim-mode (s;opt primitive-mode^) - args (import-member-args^ imports total-vars) - [io? try? maybe?] import-member-return-flags^] - (wrap (#ConstructorDecl [{#import-member-mode (default #AutoPrM ?prim-mode) - #import-member-alias (default "new" ?alias) - #import-member-kind #VirtualIMK - #import-member-tvars tvars - #import-member-args args - #import-member-maybe? maybe? - #import-member-try? try? - #import-member-io? io?} - {}])) - )) - (s;form (do s;Monad - [kind (: (Syntax ImportMethodKind) - (s;alt (s;this! (' #static)) - (wrap []))) - tvars (s;default (list) (type-params^ imports)) - name s;local-symbol - ?alias import-member-alias^ - #let [total-vars (List/append owner-vars tvars)] - ?prim-mode (s;opt primitive-mode^) - args (import-member-args^ imports total-vars) - [io? try? maybe?] import-member-return-flags^ - return (generic-type^ imports total-vars)] - (wrap (#MethodDecl [{#import-member-mode (default #AutoPrM ?prim-mode) - #import-member-alias (default name ?alias) - #import-member-kind kind - #import-member-tvars tvars - #import-member-args args - #import-member-maybe? maybe? - #import-member-try? try? - #import-member-io? io?} - {#import-method-name name - #import-method-return return - }])))) - (s;form (do s;Monad - [static? (s;this? (' #static)) - name s;local-symbol - ?prim-mode (s;opt primitive-mode^) - gtype (generic-type^ imports owner-vars) - maybe? (s;this? (' #?)) - setter? (s;this? (' #!))] - (wrap (#FieldAccessDecl {#import-field-mode (default #AutoPrM ?prim-mode) - #import-field-name name - #import-field-static? static? - #import-field-maybe? maybe? - #import-field-setter? setter? - #import-field-type gtype})))) - )) - -## Generators -(def: with-parens - (-> Code Code) - (text;enclose ["(" ")"])) - -(def: with-brackets - (-> Code Code) - (text;enclose ["[" "]"])) - -(def: spaced - (-> (List Code) Code) - (text;join-with " ")) - -(def: (privacy-modifier$ pm) - (-> PrivacyModifier Code) - (case pm - #PublicPM "public" - #PrivatePM "private" - #ProtectedPM "protected" - #DefaultPM "default")) - -(def: (inheritance-modifier$ im) - (-> InheritanceModifier Code) - (case im - #FinalIM "final" - #AbstractIM "abstract" - #DefaultIM "default")) - -(def: (annotation-param$ [name value]) - (-> AnnotationParam Code) - (format name "=" (ast;to-text value))) - -(def: (annotation$ [name params]) - (-> Annotation Code) - (format "(" name " " "{" (text;join-with "\t" (map annotation-param$ params)) "}" ")")) - -(def: (bound-kind$ kind) - (-> BoundKind Code) - (case kind - #UpperBound "<" - #LowerBound ">")) - -(def: (generic-type$ gtype) - (-> GenericType Code) - (case gtype - (#GenericTypeVar name) - name - - (#GenericClass name params) - (format "(" name " " (spaced (map generic-type$ params)) ")") - - (#GenericArray param) - (format "(" array-type-name " " (generic-type$ param) ")") - - (#GenericWildcard #;None) - "?" - - (#GenericWildcard (#;Some [bound-kind bound])) - (format (bound-kind$ bound-kind) (generic-type$ bound)))) - -(def: (type-param$ [name bounds]) - (-> TypeParam Code) - (format "(" name " " (spaced (map generic-type$ bounds)) ")")) - -(def: (class-decl$ (^open)) - (-> ClassDecl Code) - (format "(" class-name " " (spaced (map type-param$ class-params)) ")")) - -(def: (super-class-decl$ (^slots [#super-class-name #super-class-params])) - (-> SuperClassDecl Code) - (format "(" super-class-name " " (spaced (map generic-type$ super-class-params)) ")")) - -(def: (method-decl$ [[name pm anns] method-decl]) - (-> [MemberDecl MethodDecl] Code) - (let [(^slots [#method-tvars #method-inputs #method-output #method-exs]) method-decl] - (with-parens - (spaced (list name - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ method-tvars))) - (with-brackets (spaced (map generic-type$ method-exs))) - (with-brackets (spaced (map generic-type$ method-inputs))) - (generic-type$ method-output)) - )))) - -(def: (state-modifier$ sm) - (-> StateModifier Code) - (case sm - #VolatileSM "volatile" - #FinalSM "final" - #DefaultSM "default")) - -(def: (field-decl$ [[name pm anns] field]) - (-> [MemberDecl FieldDecl] Code) - (case field - (#ConstantField class value) - (with-parens - (spaced (list "constant" name - (with-brackets (spaced (map annotation$ anns))) - (generic-type$ class) - (ast;to-text value)) - )) - - (#VariableField sm class) - (with-parens - (spaced (list "variable" name - (privacy-modifier$ pm) - (state-modifier$ sm) - (with-brackets (spaced (map annotation$ anns))) - (generic-type$ class)) - )) - )) - -(def: (arg-decl$ [name type]) - (-> ArgDecl Code) - (with-parens - (spaced (list name (generic-type$ type))))) - -(def: (constructor-arg$ [class term]) - (-> ConstructorArg Code) - (with-brackets - (spaced (list (generic-type$ class) (ast;to-text term))))) - -(def: (method-def$ replacer super-class [[name pm anns] method-def]) - (-> (-> AST AST) SuperClassDecl [MemberDecl MethodDef] Code) - (case method-def - (#ConstructorMethod strict-fp? type-vars arg-decls constructor-args body exs) - (with-parens - (spaced (list "init" - (privacy-modifier$ pm) - (Bool/encode strict-fp?) - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ type-vars))) - (with-brackets (spaced (map generic-type$ exs))) - (with-brackets (spaced (map arg-decl$ arg-decls))) - (with-brackets (spaced (map constructor-arg$ constructor-args))) - (ast;to-text (pre-walk-replace replacer body)) - ))) - - (#VirtualMethod final? strict-fp? type-vars arg-decls return-type body exs) - (with-parens - (spaced (list "virtual" - name - (privacy-modifier$ pm) - (Bool/encode final?) - (Bool/encode strict-fp?) - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ type-vars))) - (with-brackets (spaced (map generic-type$ exs))) - (with-brackets (spaced (map arg-decl$ arg-decls))) - (generic-type$ return-type) - (ast;to-text (pre-walk-replace replacer body))))) - - (#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs) - (let [super-replacer (parser->replacer (s;form (do s;Monad - [_ (s;this! (' .super!)) - args (s;tuple (s;exactly (list;size arg-decls) s;any)) - #let [arg-decls' (: (List Text) (map (. (simple-class$ (list)) product;right) - arg-decls))]] - (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokespecial" ":" (get@ #super-class-name super-class) ":" name ":" (text;join-with "," arg-decls'))))] - [(~' _jvm_this) (~@ args)]))))))] - (with-parens - (spaced (list "override" - (class-decl$ class-decl) - name - (Bool/encode strict-fp?) - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ type-vars))) - (with-brackets (spaced (map generic-type$ exs))) - (with-brackets (spaced (map arg-decl$ arg-decls))) - (generic-type$ return-type) - (|> body - (pre-walk-replace replacer) - (pre-walk-replace super-replacer) - (ast;to-text)) - )))) - - (#StaticMethod strict-fp? type-vars arg-decls return-type body exs) - (with-parens - (spaced (list "static" - name - (privacy-modifier$ pm) - (Bool/encode strict-fp?) - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ type-vars))) - (with-brackets (spaced (map generic-type$ exs))) - (with-brackets (spaced (map arg-decl$ arg-decls))) - (generic-type$ return-type) - (ast;to-text (pre-walk-replace replacer body))))) - - (#AbstractMethod type-vars arg-decls return-type exs) - (with-parens - (spaced (list "abstract" - name - (privacy-modifier$ pm) - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ type-vars))) - (with-brackets (spaced (map generic-type$ exs))) - (with-brackets (spaced (map arg-decl$ arg-decls))) - (generic-type$ return-type)))) - - (#NativeMethod type-vars arg-decls return-type exs) - (with-parens - (spaced (list "native" - name - (privacy-modifier$ pm) - (with-brackets (spaced (map annotation$ anns))) - (with-brackets (spaced (map type-param$ type-vars))) - (with-brackets (spaced (map generic-type$ exs))) - (with-brackets (spaced (map arg-decl$ arg-decls))) - (generic-type$ return-type)))) - )) - -(def: (complete-call$ obj [method args]) - (-> AST PartialCall AST) - (` ((~ method) (~ args) (~ obj)))) - -## [Syntax] -(def: object-super-class - SuperClassDecl - {#super-class-name "java.lang.Object" - #super-class-params (list)}) - -(syntax: #export (class: [#let [imports (class-imports *compiler*)]] - [im inheritance-modifier^] - [class-decl (class-decl^ imports)] - [#let [full-class-name (product;left class-decl) - imports (add-import [(short-class-name full-class-name) full-class-name] - (class-imports *compiler*))]] - [#let [class-vars (product;right class-decl)]] - [super (s;default object-super-class - (super-class-decl^ imports class-vars))] - [interfaces (s;default (list) - (s;tuple (s;some (super-class-decl^ imports class-vars))))] - [annotations (annotations^ imports)] - [fields (s;some (field-decl^ imports class-vars))] - [methods (s;some (method-def^ imports class-vars))]) - {#;doc (doc "Allows defining JVM classes in Lux code." - "For example:" - (class: #final (JvmPromise A) [] - ## Fields - (#private resolved boolean) - (#private datum A) - (#private waitingList (java.util.List lux.Function)) - ## Methods - (#public [] new [] [] - (exec (:= .resolved false) - (:= .waitingList (ArrayList.new [])) - [])) - (#public [] resolve [{value A}] boolean - (let [container (.new! [])] - (synchronized _jvm_this - (if .resolved - false - (exec (:= .datum value) - (:= .resolved true) - (let [sleepers .waitingList - sleepers-count (java.util.List.size [] sleepers)] - (map (lambda [idx] - (let [sleeper (java.util.List.get [(l2i idx)] sleepers)] - (Executor.execute [(@runnable (lux.Function.apply [(:! Object value)] sleeper))] - executor))) - (i.range 0 (i.dec (i2l sleepers-count))))) - (:= .waitingList (null)) - true))))) - (#public [] poll [] A - .datum) - (#public [] wasResolved [] boolean - (synchronized _jvm_this - .resolved)) - (#public [] waitOn [{callback lux.Function}] void - (synchronized _jvm_this - (exec (if .resolved - (lux.Function.apply [(:! Object .datum)] callback) - (:! Object (java.util.List.add [callback] .waitingList))) - []))) - (#public #static [A] make [{value A}] (lux.concurrency.promise.JvmPromise A) - (let [container (.new! [])] - (exec (.resolve! (:! (host lux.concurrency.promise.JvmPromise [Unit]) container) [(:! Unit value)]) - container)))) - - "The vector corresponds to parent interfaces." - "An optional super-class can be specified before the vector. If not specified, java.lang.Object will be assumed." - "Fields and methods defined in the class can be used with special syntax." - "For example:" - ".resolved, for accessing the \"resolved\" field." - "(:= .resolved true) for modifying it." - "(.new! []) for calling the class's constructor." - "(.resolve! container [value]) for calling the \"resolve\" method." - )} - (do Monad - [current-module compiler;current-module-name - #let [fully-qualified-class-name (format (text;replace "/" "." current-module) "." full-class-name) - field-parsers (map (field->parser fully-qualified-class-name) fields) - method-parsers (map (method->parser (product;right class-decl) fully-qualified-class-name) methods) - replacer (parser->replacer (fold s;either - (s;fail "") - (List/append field-parsers method-parsers))) - def-code (format "class:" - (spaced (list (class-decl$ class-decl) - (super-class-decl$ super) - (with-brackets (spaced (map super-class-decl$ interfaces))) - (inheritance-modifier$ im) - (with-brackets (spaced (map annotation$ annotations))) - (with-brackets (spaced (map field-decl$ fields))) - (with-brackets (spaced (map (method-def$ replacer super) methods))))))]] - (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))) - -(syntax: #export (interface: [#let [imports (class-imports *compiler*)]] - [class-decl (class-decl^ imports)] - [#let [full-class-name (product;left class-decl) - imports (add-import [(short-class-name full-class-name) full-class-name] - (class-imports *compiler*))]] - [#let [class-vars (product;right class-decl)]] - [supers (s;default (list) - (s;tuple (s;some (super-class-decl^ imports class-vars))))] - [annotations (annotations^ imports)] - [members (s;some (method-decl^ imports class-vars))]) - {#;doc (doc "Allows defining JVM interfaces." - (interface: TestInterface - ([] foo [boolean String] void #throws [Exception])))} - (let [def-code (format "interface:" - (spaced (list (class-decl$ class-decl) - (with-brackets (spaced (map super-class-decl$ supers))) - (with-brackets (spaced (map annotation$ annotations))) - (spaced (map method-decl$ members)))))] - (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))) - )) - -(syntax: #export (object [#let [imports (class-imports *compiler*)]] - [#let [class-vars (list)]] - [super (s;default object-super-class - (super-class-decl^ imports class-vars))] - [interfaces (s;default (list) - (s;tuple (s;some (super-class-decl^ imports class-vars))))] - [constructor-args (constructor-args^ imports class-vars)] - [methods (s;some (overriden-method-def^ imports))]) - {#;doc (doc "Allows defining anonymous classes." - "The 1st vector corresponds to parent interfaces." - "The 2nd vector corresponds to arguments to the super class constructor." - "An optional super-class can be specified before the 1st vector. If not specified, java.lang.Object will be assumed." - (object [java.lang.Runnable] - [] - (java.lang.Runnable (run) void - (exec (do-something some-input) - []))) - )} - (let [def-code (format "anon-class:" - (spaced (list (super-class-decl$ super) - (with-brackets (spaced (map super-class-decl$ interfaces))) - (with-brackets (spaced (map constructor-arg$ constructor-args))) - (with-brackets (spaced (map (method-def$ id super) methods))))))] - (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))) - -(syntax: #export (null) - {#;doc (doc "Null object reference." - (null))} - (wrap (list (` (;_lux_proc ["jvm" "null"] []))))) - -(def: #export (null? obj) - {#;doc (doc "Test for null object reference." - (null? (null)) - "=>" - true - (null? "YOLO") - "=>" - false)} - (-> (host java.lang.Object) Bool) - (;_lux_proc ["jvm" "null?"] [obj])) - -(syntax: #export (??? expr) - {#;doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it." - (??? (: java.lang.String (null))) - "=>" - #;None - (??? "YOLO") - "=>" - (#;Some "YOLO"))} - (with-gensyms [g!temp] - (wrap (list (` (let [(~ g!temp) (~ expr)] - (if (;_lux_proc ["jvm" "null?"] [(~ g!temp)]) - #;None - (#;Some (~ g!temp))))))))) - -(syntax: #export (!!! expr) - {#;doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType." - "A #;None would get translated into a (null)." - (!!! (??? (: java.lang.Thread (null)))) - "=>" - (null) - (!!! (??? "YOLO")) - "=>" - "YOLO")} - (with-gensyms [g!value] - (wrap (list (` (;_lux_case (~ expr) - (#;Some (~ g!value)) - (~ g!value) - - #;None - (;_lux_proc ["jvm" "null"] []))))))) - -(syntax: #export (try expr) - {#;doc (doc "Covers the expression in a try-catch block." - "If it succeeds, you get (#;Right result)." - "If it fails, you get (#;Left error+stack-traces-as-text)." - (try (risky-computation input)))} - (wrap (list (`' (_lux_proc ["jvm" "try"] - [(#;Right (~ expr)) - ;;throwable->text]))))) - -(syntax: #export (instance? [#let [imports (class-imports *compiler*)]] - [class (generic-type^ imports (list))] - [obj (s;opt s;any)]) - {#;doc (doc "Checks whether an object is an instance of a particular class." - "Caveat emptor: Can't check for polymorphism, so avoid using parameterized classes." - (instance? String "YOLO"))} - (case obj - (#;Some obj) - (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ obj)])))) - - #;None - (do @ - [g!obj (compiler;gensym "obj")] - (wrap (list (` (: (-> (host (~' java.lang.Object)) Bool) - (lambda [(~ g!obj)] - (;_lux_proc ["jvm" (~ (ast;text (format "instanceof" ":" (simple-class$ (list) class))))] [(~ g!obj)]))))))) - )) - -(syntax: #export (synchronized lock body) - {#;doc (doc "Evaluates body, while holding a lock on a given object." - (synchronized object-to-be-locked - (exec (do-something ...) - (do-something-else ...) - (finish-the-computation ...))))} - (wrap (list (` (;_lux_proc ["jvm" "synchronized"] [(~ lock) (~ body)]))))) - -(syntax: #export (do-to obj [methods (s;some partial-call^)]) - {#;doc (doc "Call a variety of methods on an object; then return the object." - (do-to vreq - (HttpServerRequest.setExpectMultipart [true]) - (ReadStream.handler [(object [(Handler Buffer)] - [] - ((Handler A) (handle [buffer A]) void - (io;run (do Monad - [_ (write (Buffer.getBytes [] buffer) body)] - (wrap [])))) - )]) - (ReadStream.endHandler [[(object [(Handler Void)] - [] - ((Handler A) (handle [_ A]) void - (exec (do Monad - [#let [_ (io;run (close body))] - response (handler (request$ vreq body))] - (respond! response vreq)) - [])) - )]])))} - (with-gensyms [g!obj] - (wrap (list (` (let [(~ g!obj) (~ obj)] - (exec (~@ (map (complete-call$ g!obj) methods)) - (~ g!obj)))))))) - -(def: (class-import$ long-name? [full-name params]) - (-> Bool ClassDecl AST) - (let [def-name (if long-name? - full-name - (short-class-name full-name))] - (case params - #;Nil - (` (def: (~ (ast;symbol ["" def-name])) - {#;type? true - #;;jvm-class (~ (ast;text full-name))} - Type - (host (~ (ast;symbol ["" full-name]))))) - - (#;Cons _) - (let [params' (map (lambda [[p _]] (ast;symbol ["" p])) params)] - (` (def: (~ (ast;symbol ["" def-name])) - {#;type? true - #;;jvm-class (~ (ast;text full-name))} - Type - (All [(~@ params')] - (host (~ (ast;symbol ["" full-name])) - [(~@ params')])))))))) - -(def: (member-type-vars class-tvars member) - (-> (List TypeParam) ImportMemberDecl (List TypeParam)) - (case member - (#ConstructorDecl [commons _]) - (List/append class-tvars (get@ #import-member-tvars commons)) - - (#MethodDecl [commons _]) - (case (get@ #import-member-kind commons) - #StaticIMK - (get@ #import-member-tvars commons) - - _ - (List/append class-tvars (get@ #import-member-tvars commons))) - - _ - class-tvars)) - -(def: (member-def-arg-bindings type-params class member) - (-> (List TypeParam) ClassDecl ImportMemberDecl (Lux [(List AST) (List AST) (List Text) (List AST)])) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (let [(^slots [#import-member-tvars #import-member-args]) commons] - (do Monad - [arg-inputs (mapM @ - (: (-> [Bool GenericType] (Lux [AST AST])) - (lambda [[maybe? _]] - (with-gensyms [arg-name] - (wrap [arg-name (if maybe? - (` (!!! (~ arg-name))) - arg-name)])))) - import-member-args) - #let [arg-classes (: (List Text) - (map (. (simple-class$ (List/append type-params import-member-tvars)) product;right) - import-member-args)) - arg-types (map (: (-> [Bool GenericType] AST) - (lambda [[maybe? arg]] - (let [arg-type (class->type (get@ #import-member-mode commons) type-params arg)] - (if maybe? - (` (Maybe (~ arg-type))) - arg-type)))) - import-member-args) - arg-lambda-inputs (map product;left arg-inputs) - arg-method-inputs (map product;right arg-inputs)]] - (wrap [arg-lambda-inputs arg-method-inputs arg-classes arg-types]))) - - _ - (:: Monad wrap [(list) (list) (list) (list)]))) - -(def: (member-def-return mode type-params class member) - (-> Primitive-Mode (List TypeParam) ClassDecl ImportMemberDecl (Lux AST)) - (case member - (#ConstructorDecl _) - (:: Monad wrap (class-decl-type$ class)) - - (#MethodDecl [_ method]) - (:: Monad wrap (class->type mode type-params (get@ #import-method-return method))) - - _ - (compiler;fail "Only methods have return values."))) - -(def: (decorate-return-maybe member [return-type return-term]) - (-> ImportMemberDecl [AST AST] [AST AST]) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (if (get@ #import-member-maybe? commons) - [(` (Maybe (~ return-type))) - (` (??? (~ return-term)))] - [return-type - (let [g!temp (ast;symbol ["" "Ω"])] - (` (let [(~ g!temp) (~ return-term)] - (if (null? (:! (host (~' java.lang.Object)) - (~ g!temp))) - (error! "Can't produce null references from method calls.") - (~ g!temp)))))]) - - _ - [return-type return-term])) - -(do-template [ ] - [(def: ( member [return-type return-term]) - (-> ImportMemberDecl [AST AST] [AST AST]) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (if (get@ commons) - [ ] - [return-type return-term]) - - _ - [return-type return-term]))] - - [decorate-return-try #import-member-try? (` (Either Text (~ return-type))) (` (try (~ return-term)))] - [decorate-return-io #import-member-io? (` (IO (~ return-type))) (` (io (~ return-term)))] - ) - -(def: (free-type-param? [name bounds]) - (-> TypeParam Bool) - (case bounds - #;Nil true - _ false)) - -(def: (type-param->type-arg [name _]) - (-> TypeParam AST) - (ast;symbol ["" name])) - -(def: (with-mode-output mode output-type body) - (-> Primitive-Mode GenericType AST AST) - (case mode - #ManualPrM - body - - #AutoPrM - (case output-type - (#GenericClass ["byte" _]) - (` (b2l (~ body))) - - (#GenericClass ["short" _]) - (` (s2l (~ body))) - - (#GenericClass ["int" _]) - (` (i2l (~ body))) - - (#GenericClass ["float" _]) - (` (f2d (~ body))) - - _ - body))) - -(def: (auto-conv-class? class) - (-> Text Bool) - (case class - (^or "byte" "short" "int" "float") - true - - _ - false)) - -(def: (auto-conv [class var]) - (-> [Text AST] (List AST)) - (case class - "byte" (list var (` (l2b (~ var)))) - "short" (list var (` (l2s (~ var)))) - "int" (list var (` (l2i (~ var)))) - "float" (list var (` (d2f (~ var)))) - _ (list))) - -(def: (with-mode-inputs mode inputs body) - (-> Primitive-Mode (List [Text AST]) AST AST) - (case mode - #ManualPrM - body - - #AutoPrM - (` (let [(~@ (|> inputs - (List/map auto-conv) - List/join))] - (~ body))))) - -(def: (with-mode-field-get mode class output) - (-> Primitive-Mode GenericType AST AST) - (case mode - #ManualPrM - output - - #AutoPrM - (case (simple-class$ (list) class) - "byte" (` (b2l (~ output))) - "short" (` (s2l (~ output))) - "int" (` (i2l (~ output))) - "float" (` (f2d (~ output))) - _ output))) - -(def: (with-mode-field-set mode class input) - (-> Primitive-Mode GenericType AST AST) - (case mode - #ManualPrM - input - - #AutoPrM - (case (simple-class$ (list) class) - "byte" (` (l2b (~ input))) - "short" (` (l2s (~ input))) - "int" (` (l2i (~ input))) - "float" (` (d2f (~ input))) - _ input))) - -(def: (member-def-interop type-params kind class [arg-lambda-inputs arg-method-inputs arg-classes arg-types] member method-prefix) - (-> (List TypeParam) ClassKind ClassDecl [(List AST) (List AST) (List Text) (List AST)] ImportMemberDecl Text (Lux (List AST))) - (let [[full-name class-tvars] class - all-params (|> (member-type-vars class-tvars member) - (filter free-type-param?) - (map type-param->type-arg))] - (case member - (#EnumDecl enum-members) - (do Monad - [#let [enum-type (: AST - (case class-tvars - #;Nil - (` (host (~ (ast;symbol ["" full-name])))) - - _ - (let [=class-tvars (|> class-tvars - (filter free-type-param?) - (map type-param->type-arg))] - (` (All [(~@ =class-tvars)] (host (~ (ast;symbol ["" full-name])) [(~@ =class-tvars)])))))) - getter-interop (: (-> Text AST) - (lambda [name] - (let [getter-name (ast;symbol ["" (format method-prefix member-separator name)])] - (` (def: (~ getter-name) - (~ enum-type) - (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" name)))] []))))))]] - (wrap (map getter-interop enum-members))) - - (#ConstructorDecl [commons _]) - (do Monad - [return-type (member-def-return (get@ #import-member-mode commons) type-params class member) - #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) - def-params (list (ast;tuple arg-lambda-inputs)) - jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" full-name ":" (text;join-with "," arg-classes))))] - [(~@ arg-method-inputs)])) - (with-mode-inputs (get@ #import-member-mode commons) - (list;zip2 arg-classes arg-lambda-inputs))) - [return-type jvm-interop] (|> [return-type jvm-interop] - (decorate-return-maybe member) - (decorate-return-try member) - (decorate-return-io member))]] - (wrap (list (` (def: ((~ def-name) (~@ def-params)) - (All [(~@ all-params)] (-> [(~@ arg-types)] (~ return-type))) - (~ jvm-interop)))))) - - (#MethodDecl [commons method]) - (with-gensyms [g!obj] - (do @ - [return-type (member-def-return (get@ #import-member-mode commons) type-params class member) - #let [def-name (ast;symbol ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) - (^slots [#import-member-kind]) commons - (^slots [#import-method-name]) method - [jvm-op obj-ast class-ast] (: [Text (List AST) (List AST)] - (case import-member-kind - #StaticIMK - ["invokestatic" - (list) - (list)] - - #VirtualIMK - (case kind - #Class - ["invokevirtual" - (list g!obj) - (list (class-decl-type$ class))] - - #Interface - ["invokeinterface" - (list g!obj) - (list (class-decl-type$ class))] - ))) - def-params (#;Cons (ast;tuple arg-lambda-inputs) obj-ast) - def-param-types (#;Cons (` [(~@ arg-types)]) class-ast) - jvm-interop (|> (` (;_lux_proc ["jvm" (~ (ast;text (format jvm-op ":" full-name ":" import-method-name - ":" (text;join-with "," arg-classes))))] - [(~@ obj-ast) (~@ arg-method-inputs)])) - (with-mode-output (get@ #import-member-mode commons) - (get@ #import-method-return method)) - (with-mode-inputs (get@ #import-member-mode commons) - (list;zip2 arg-classes arg-lambda-inputs))) - [return-type jvm-interop] (|> [return-type jvm-interop] - (decorate-return-maybe member) - (decorate-return-try member) - (decorate-return-io member))]] - (wrap (list (` (def: ((~ def-name) (~@ def-params)) - (All [(~@ all-params)] (-> (~@ def-param-types) (~ return-type))) - (~ jvm-interop))))))) - - (#FieldAccessDecl fad) - (do Monad - [#let [(^open) fad - base-gtype (class->type import-field-mode type-params import-field-type) - g!class (class-decl-type$ class) - g!type (if import-field-maybe? - (` (Maybe (~ base-gtype))) - base-gtype) - tvar-asts (: (List AST) - (|> class-tvars - (filter free-type-param?) - (map type-param->type-arg))) - getter-name (ast;symbol ["" (format method-prefix member-separator import-field-name)]) - setter-name (ast;symbol ["" (format method-prefix member-separator import-field-name "!")])] - getter-interop (with-gensyms [g!obj] - (let [getter-call (if import-field-static? - getter-name - (` ((~ getter-name) (~ g!obj)))) - getter-type (if import-field-setter? - (` (IO (~ g!type))) - g!type) - getter-type (if import-field-static? - getter-type - (` (-> (~ g!class) (~ getter-type)))) - getter-type (` (All [(~@ tvar-asts)] (~ getter-type))) - getter-body (if import-field-static? - (with-mode-field-get import-field-mode import-field-type - (` (;_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" full-name ":" import-field-name)))] []))) - (with-mode-field-get import-field-mode import-field-type - (` (;_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" full-name ":" import-field-name)))] [(~ g!obj)])))) - getter-body (if import-field-maybe? - (` (??? (~ getter-body))) - getter-body) - getter-body (if import-field-setter? - (` (io (~ getter-body))) - getter-body)] - (wrap (` (def: (~ getter-call) - (~ getter-type) - (~ getter-body)))))) - setter-interop (if import-field-setter? - (with-gensyms [g!obj g!value] - (let [setter-call (if import-field-static? - (` ((~ setter-name) (~ g!value))) - (` ((~ setter-name) (~ g!value) (~ g!obj)))) - setter-type (if import-field-static? - (` (All [(~@ tvar-asts)] (-> (~ g!type) (IO Unit)))) - (` (All [(~@ tvar-asts)] (-> (~ g!type) (~ g!class) (IO Unit))))) - setter-value (with-mode-field-set import-field-mode import-field-type g!value) - setter-value (if import-field-maybe? - (` (!!! (~ setter-value))) - setter-value) - setter-command (format (if import-field-static? "putstatic" "putfield") - ":" full-name ":" import-field-name)] - (wrap (: (List AST) - (list (` (def: (~ setter-call) - (~ setter-type) - (io (;_lux_proc ["jvm" (~ (ast;text setter-command))] - [(~ setter-value)]))))))))) - (wrap (list)))] - (wrap (list& getter-interop setter-interop))) - ))) - -(def: (member-import$ type-params long-name? kind class member) - (-> (List TypeParam) Bool ClassKind ClassDecl ImportMemberDecl (Lux (List AST))) - (let [[full-name _] class - method-prefix (if long-name? - full-name - (short-class-name full-name))] - (do Monad - [=args (member-def-arg-bindings type-params class member)] - (member-def-interop type-params kind class =args member method-prefix)))) - -(def: (interface? class) - (All [a] (-> (host java.lang.Class [a]) Bool)) - (_lux_proc ["jvm" "invokevirtual:java.lang.Class:isInterface:"] [class])) - -(def: (load-class class-name) - (-> Text (Either Text (host java.lang.Class [(Ex [a] a)]))) - (try (_lux_proc ["jvm" "invokestatic:java.lang.Class:forName:java.lang.String"] [class-name]))) - -(def: (class-kind [class-name _]) - (-> ClassDecl (Lux ClassKind)) - (case (load-class class-name) - (#;Right class) - (:: Monad wrap (if (interface? class) - #Interface - #Class)) - - (#;Left _) - (compiler;fail (format "Unknown class: " class-name)))) - -(syntax: #export (jvm-import [#let [imports (class-imports *compiler*)]] - [long-name? (s;this? (' #long))] - [class-decl (class-decl^ imports)] - [#let [full-class-name (product;left class-decl) - imports (add-import [(short-class-name full-class-name) full-class-name] - (class-imports *compiler*))]] - [members (s;some (import-member-decl^ imports (product;right class-decl)))]) - {#;doc (doc "Allows importing JVM classes, and using them as types." - "Their methods, fields and enum options can also be imported." - "Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes." - "Examples:" - (jvm-import java.lang.Object - (new []) - (equals [Object] boolean) - (wait [int] #io #try void)) - "Special options can also be given for the return values." - "#? means that the values will be returned inside a Maybe type. That way, null becomes #;None." - "#try means that the computation might throw an exception, and the return value will be wrapped by the Error type." - "#io means the computation has side effects, and will be wrapped by the IO type." - "These options must show up in the following order [#io #try #?] (although, each option can be used independently)." - (jvm-import java.lang.String - (new [(Array byte)]) - (#static valueOf [char] String) - (#static valueOf #as int-valueOf [int] String)) - - (jvm-import #long (java.util.List e) - (size [] int) - (get [int] e)) - - (jvm-import (java.util.ArrayList a) - ([T] toArray [(Array T)] (Array T))) - "#long makes it so the class-type that is generated is of the fully-qualified name." - "In this case, it avoids a clash between the java.util.List type, and Lux's own List type." - (jvm-import java.lang.Character$UnicodeScript - (#enum ARABIC CYRILLIC LATIN)) - "All enum options to be imported must be specified." - - (jvm-import #long (lux.concurrency.promise.JvmPromise A) - (resolve [A] boolean) - (poll [] A) - (wasResolved [] boolean) - (waitOn [lux.Function] void) - (#static [A] make [A] (JvmPromise A))) - "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters." - "Lux types, such as Maybe can't be named (otherwise, they'd be confused for Java classes)." - - "Also, the names of the imported members will look like ClassName.MemberName." - "E.g.:" - (Object.new []) - (Object.equals [other-object] my-object) - (java.util.List.size [] my-list) - Character$UnicodeScript.LATIN - )} - (do Monad - [kind (class-kind class-decl) - =members (mapM @ (member-import$ (product;right class-decl) long-name? kind class-decl) members)] - (wrap (list& (class-import$ long-name? class-decl) (List/join =members))))) - -(syntax: #export (array [#let [imports (class-imports *compiler*)]] - [type (generic-type^ imports (list))] - size) - {#;doc (doc "Create an array of the given type, with the given size." - (array Object +10))} - (case type - (^template [ ] - (^ (#GenericClass (list))) - (wrap (list (` (;_lux_proc ["jvm" ] [(~ size)]))))) - (["boolean" "znewarray"] - ["byte" "bnewarray"] - ["short" "snewarray"] - ["int" "inewarray"] - ["long" "lnewarray"] - ["float" "fnewarray"] - ["double" "dnewarray"] - ["char" "cnewarray"]) - - _ - (wrap (list (` (;_lux_proc ["jvm" "anewarray"] [(~ (ast;text (generic-type$ type))) (~ size)])))))) - -(syntax: #export (array-length array) - {#;doc (doc "Gives the length of an array." - (array-length my-array))} - (wrap (list (` (;_lux_proc ["jvm" "arraylength"] [(~ array)]))))) - -(def: (type->class-name type) - (-> Type (Lux Text)) - (case type - (#;HostT name params) - (:: Monad wrap name) - - (#;AppT F A) - (case (type;apply-type F A) - #;None - (compiler;fail (format "Can't apply type: " (type;to-text F) " to " (type;to-text A))) - - (#;Some type') - (type->class-name type')) - - (#;NamedT _ type') - (type->class-name type') - - #;UnitT - (:: Monad wrap "java.lang.Object") - - (^or #;VoidT (#;VarT _) (#;ExT _) (#;BoundT _) (#;SumT _) (#;ProdT _) (#;LambdaT _) (#;UnivQ _) (#;ExQ _)) - (compiler;fail (format "Can't convert to JvmType: " (type;to-text type))) - )) - -(syntax: #export (array-load idx array) - {#;doc (doc "Loads an element from an array." - (array-load 10 my-array))} - (case array - [_ (#;SymbolS array-name)] - (do Monad - [array-type (compiler;find-type array-name) - array-jvm-type (type->class-name array-type)] - (case array-jvm-type - (^template [ ] - - (wrap (list (` (;_lux_proc ["jvm" ] [(~ array) (~ idx)]))))) - (["[Z" "zaload"] - ["[B" "baload"] - ["[S" "saload"] - ["[I" "iaload"] - ["[J" "jaload"] - ["[F" "faload"] - ["[D" "daload"] - ["[C" "caload"]) - - _ - (wrap (list (` (;_lux_proc ["jvm" "aaload"] [(~ array) (~ idx)])))))) - - _ - (with-gensyms [g!array] - (wrap (list (` (let [(~ g!array) (~ array)] - (;;array-load (~ g!array) (~ idx))))))))) - -(syntax: #export (array-store idx value array) - {#;doc (doc "Stores an element into an array." - (array-store 10 my-object my-array))} - (case array - [_ (#;SymbolS array-name)] - (do Monad - [array-type (compiler;find-type array-name) - array-jvm-type (type->class-name array-type)] - (case array-jvm-type - (^template [ ] - - (wrap (list (` (;_lux_proc ["jvm" ] [(~ array) (~ idx) (~ value)]))))) - (["[Z" "zastore"] - ["[B" "bastore"] - ["[S" "sastore"] - ["[I" "iastore"] - ["[J" "jastore"] - ["[F" "fastore"] - ["[D" "dastore"] - ["[C" "castore"]) - - _ - (wrap (list (` (;_lux_proc ["jvm" "aastore"] [(~ array) (~ idx) (~ value)])))))) - - _ - (with-gensyms [g!array] - (wrap (list (` (let [(~ g!array) (~ array)] - (;;array-store (~ g!array) (~ idx) (~ value))))))))) - -(def: simple-bindings^ - (Syntax (List [Text AST])) - (s;tuple (s;some (s;seq s;local-symbol s;any)))) - -(syntax: #export (with-open [bindings simple-bindings^] body) - {#;doc (doc "Creates a local-binding with the desired resources, and runs the body (assumed to be in the IO type)." - "Afterwards, closes all resources (assumed to be subclasses of java.io.Closeable), and returns the value resulting from running the body." - (with-open [my-res1 (res1-constructor ...) - my-res2 (res1-constructor ...)] - (do Monad - [foo (do-something my-res1) - bar (do-something-else my-res2)] - (do-one-last-thing foo bar))))} - (with-gensyms [g!output g!_] - (let [inits (List/join (List/map (lambda [[res-name res-ctor]] - (list (ast;symbol ["" res-name]) res-ctor)) - bindings)) - closes (List/map (lambda [res] - (` (try (;_lux_proc ["jvm" "invokevirtual:java.io.Closeable:close:"] - [(~ (ast;symbol ["" (product;left res)]))])))) - bindings)] - (wrap (list (` (do Monad - [(~@ inits) - (~ g!output) (~ body) - (~' #let) [(~ g!_) (exec (~@ (reverse closes)) [])]] - ((~' wrap) (~ g!output))))))))) - -(syntax: #export (class-for [#let [imports (class-imports *compiler*)]] - [type (generic-type^ imports (list))]) - {#;doc (doc "Loads the class as a java.lang.Class object." - (class-for java.lang.String))} - (wrap (list (` (;_lux_proc ["jvm" "load-class"] [(~ (ast;text (simple-class$ (list) type)))]))))) - -(def: get-compiler - (Lux Compiler) - (lambda [compiler] - (#;Right [compiler compiler]))) - -(def: (fully-qualify-class-name+ imports name) - (-> ClassImports Text (Maybe Text)) - (cond (fully-qualified-class-name? name) - (#;Some name) - - (member? text;Eq java.lang-classes name) - (#;Some (format "java.lang." name)) - - ## else - (get-import name imports))) - -(def: #export (resolve-class class) - {#;doc (doc "Given a potentially unqualified class name, qualifies it if necessary." - (resolve-class "String") - => - "java.lang.String")} - (-> Text (Lux Text)) - (do Monad - [*compiler* get-compiler] - (case (fully-qualify-class-name+ (class-imports *compiler*) class) - (#;Some fqcn) - (wrap fqcn) - - #;None - (compiler;fail (Text/append "Unknown class: " class))))) diff --git a/stdlib/test/test/lux/host.js.lux b/stdlib/test/test/lux/host.js.lux new file mode 100644 index 000000000..4c2b55485 --- /dev/null +++ b/stdlib/test/test/lux/host.js.lux @@ -0,0 +1,32 @@ +(;module: + lux + (lux [io] + (control monad) + (data text/format) + ["&" host] + ["R" random] + pipe) + lux/test) + +(test: "JavaScript operations" + ($_ seq + (assert "Null equals itself." + (is (&;null) (&;null))) + + (assert "Undefined equals itself." + (is (&;undef) (&;undef))) + + (assert "Can reference JavaScript objects." + (is (&;ref "Math") (&;ref "Math"))) + + (assert "Can create objects and access their fields." + (|> (&;object "foo" "BAR") + (&;get "foo" Text) + (is "BAR"))) + + (assert "Can call JavaScript functions" + (and (is 124.0 + (&;call! (&;ref "Math.ceil" &;Function) [123.45] Real)) + (is 124.0 + (&;call! (&;ref "Math") "ceil" [123.45] Real)))) + )) diff --git a/stdlib/test/test/lux/host.jvm.lux b/stdlib/test/test/lux/host.jvm.lux new file mode 100644 index 000000000..54e6cf4b9 --- /dev/null +++ b/stdlib/test/test/lux/host.jvm.lux @@ -0,0 +1,121 @@ +(;module: + lux + (lux [io] + (control monad) + (data text/format + [number] + [product] + [text "Text/" Eq]) + (codata function) + ["&" host #+ jvm-import class: interface: object] + ["R" random] + pipe) + lux/test) + +(jvm-import java.lang.Exception + (new [String])) + +(jvm-import java.lang.Object) + +(jvm-import (java.lang.Class a) + (getName [] String)) + +(jvm-import java.lang.System + (#static out java.io.PrintStream) + (#static currentTimeMillis [] #io long) + (#static getenv [String] #io #? String)) + +(class: #final (TestClass A) [Runnable] + ## Fields + (#private foo boolean) + (#private bar A) + (#private baz java.lang.Object) + ## Methods + (#public [] (new [value A]) [] + (exec (:= .foo true) + (:= .bar value) + (:= .baz "") + [])) + (#public (virtual) java.lang.Object + "") + (#public #static (static) java.lang.Object + "") + (Runnable [] (run) void + []) + ) + +(def: test-runnable + (object [Runnable] + [] + (Runnable [] (run) void + []))) + +(interface: TestInterface + ([] foo [boolean String] void #throws [Exception])) + +(test: "Conversions" + [sample R;int] + (let% [ (do-template [ ] + [(assert + (or (|> sample (i.= sample)) + (let [capped-sample (|> sample )] + (|> capped-sample (i.= capped-sample)))))] + + [&;l2b &;b2l "Can succesfully convert to/from byte."] + [&;l2s &;s2l "Can succesfully convert to/from short."] + [&;l2i &;i2l "Can succesfully convert to/from int."] + [&;l2f &;f2l "Can succesfully convert to/from float."] + [&;l2d &;d2l "Can succesfully convert to/from double."] + [(<| &;i2c &;l2i) (<| &;i2l &;c2i) "Can succesfully convert to/from char."] + )] + ($_ seq + + ))) + +(test: "Miscellaneous" + ($_ seq + (assert "Can check if an object is of a certain class." + (and (&;instance? String "") + (not (&;instance? Long "")) + (&;instance? Object "") + (not (&;instance? Object (&;null))))) + + (assert "Can run code in a \"synchronized\" block." + (&;synchronized "" true)) + + ## (assert "Can safely try risky code." + ## (and (case (&;try []) + ## (#;Right _) true + ## (#;Left _) false) + ## (case (&;try (_lux_proc ["jvm" "throw"] [(Exception.new "Uh, oh...")])) + ## (#;Right _) false + ## (#;Left _) true))) + + (assert "Can access Class instances." + (Text/= "java.lang.Class" (Class.getName [] (&;class-for java.lang.Class)))) + + (assert "Can check if a value is null." + (and (&;null? (&;null)) + (not (&;null? "")))) + + (assert "Can safely convert nullable references into Maybe values." + (and (|> (: (Maybe Object) (&;??? (&;null))) + (case> #;None true + _ false)) + (|> (: (Maybe Object) (&;??? "")) + (case> (#;Some _) true + _ false)))) + )) + +(test: "Arrays" + [size (|> R;nat (:: @ map (|>. (n.% +100) (n.max +1)))) + idx (|> R;nat (:: @ map (n.% size))) + value R;int] + ($_ seq + (assert "Can create arrays of some length." + (n.= size (&;array-length (&;array Long size)))) + + (assert "Can set and get array values." + (let [arr (&;array Long size)] + (exec (&;array-store idx value arr) + (i.= value (&;array-load idx arr))))))) diff --git a/stdlib/test/test/lux/host.lux b/stdlib/test/test/lux/host.lux deleted file mode 100644 index 54e6cf4b9..000000000 --- a/stdlib/test/test/lux/host.lux +++ /dev/null @@ -1,121 +0,0 @@ -(;module: - lux - (lux [io] - (control monad) - (data text/format - [number] - [product] - [text "Text/" Eq]) - (codata function) - ["&" host #+ jvm-import class: interface: object] - ["R" random] - pipe) - lux/test) - -(jvm-import java.lang.Exception - (new [String])) - -(jvm-import java.lang.Object) - -(jvm-import (java.lang.Class a) - (getName [] String)) - -(jvm-import java.lang.System - (#static out java.io.PrintStream) - (#static currentTimeMillis [] #io long) - (#static getenv [String] #io #? String)) - -(class: #final (TestClass A) [Runnable] - ## Fields - (#private foo boolean) - (#private bar A) - (#private baz java.lang.Object) - ## Methods - (#public [] (new [value A]) [] - (exec (:= .foo true) - (:= .bar value) - (:= .baz "") - [])) - (#public (virtual) java.lang.Object - "") - (#public #static (static) java.lang.Object - "") - (Runnable [] (run) void - []) - ) - -(def: test-runnable - (object [Runnable] - [] - (Runnable [] (run) void - []))) - -(interface: TestInterface - ([] foo [boolean String] void #throws [Exception])) - -(test: "Conversions" - [sample R;int] - (let% [ (do-template [ ] - [(assert - (or (|> sample (i.= sample)) - (let [capped-sample (|> sample )] - (|> capped-sample (i.= capped-sample)))))] - - [&;l2b &;b2l "Can succesfully convert to/from byte."] - [&;l2s &;s2l "Can succesfully convert to/from short."] - [&;l2i &;i2l "Can succesfully convert to/from int."] - [&;l2f &;f2l "Can succesfully convert to/from float."] - [&;l2d &;d2l "Can succesfully convert to/from double."] - [(<| &;i2c &;l2i) (<| &;i2l &;c2i) "Can succesfully convert to/from char."] - )] - ($_ seq - - ))) - -(test: "Miscellaneous" - ($_ seq - (assert "Can check if an object is of a certain class." - (and (&;instance? String "") - (not (&;instance? Long "")) - (&;instance? Object "") - (not (&;instance? Object (&;null))))) - - (assert "Can run code in a \"synchronized\" block." - (&;synchronized "" true)) - - ## (assert "Can safely try risky code." - ## (and (case (&;try []) - ## (#;Right _) true - ## (#;Left _) false) - ## (case (&;try (_lux_proc ["jvm" "throw"] [(Exception.new "Uh, oh...")])) - ## (#;Right _) false - ## (#;Left _) true))) - - (assert "Can access Class instances." - (Text/= "java.lang.Class" (Class.getName [] (&;class-for java.lang.Class)))) - - (assert "Can check if a value is null." - (and (&;null? (&;null)) - (not (&;null? "")))) - - (assert "Can safely convert nullable references into Maybe values." - (and (|> (: (Maybe Object) (&;??? (&;null))) - (case> #;None true - _ false)) - (|> (: (Maybe Object) (&;??? "")) - (case> (#;Some _) true - _ false)))) - )) - -(test: "Arrays" - [size (|> R;nat (:: @ map (|>. (n.% +100) (n.max +1)))) - idx (|> R;nat (:: @ map (n.% size))) - value R;int] - ($_ seq - (assert "Can create arrays of some length." - (n.= size (&;array-length (&;array Long size)))) - - (assert "Can set and get array values." - (let [arr (&;array Long size)] - (exec (&;array-store idx value arr) - (i.= value (&;array-load idx arr))))))) -- cgit v1.3.1