From 97d1a9d0c5b469c3de4e9ee8af33e5a9d3144cb6 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 30 Jan 2017 17:35:20 -0400 Subject: - More refactorings. - Changed the place where module-compilation-state was being stored. - No longer keeping the compiler's name as part of the compiler's state. --- stdlib/source/lux.lux | 63 +++++++++++++++++++++++++++++++++------------------ 1 file changed, 41 insertions(+), 22 deletions(-) (limited to 'stdlib') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 520e55434..19a7b4716 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -485,6 +485,26 @@ Text])])) default-def-meta-exported) +## (type: Module-State +## #Active +## #Compiled +## #Cached) +(_lux_def Module-State + (#NamedT ["lux" "Module-State"] + (#SumT + ## #Active + Unit + (#SumT + ## #Compiled + Unit + ## #Cached + Unit))) + (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "Active") + (#Cons (#TextA "Compiled") + (#Cons (#TextA "Cached") + #Nil))))] + default-def-meta-exported)) + ## (type: Module ## {#module-hash Int ## #module-aliases (List [Text Text]) @@ -493,6 +513,7 @@ ## #tags (List [Text [Nat (List Ident) Bool Type]]) ## #types (List [Text [(List Ident) Bool Type]])} ## #module-anns Anns +## #module-state Module-State ## ) (_lux_def Module (#NamedT ["lux" "Module"] @@ -518,8 +539,9 @@ (#ProdT (#AppT List Ident) (#ProdT Bool Type)))) - ## "lux;module-anns" - Anns) + (#ProdT ## "lux;module-anns" + Anns + Module-State)) )))))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "module-hash") (#Cons (#TextA "module-aliases") @@ -528,7 +550,8 @@ (#Cons (#TextA "tags") (#Cons (#TextA "types") (#Cons (#TextA "module-anns") - #Nil))))))))] + (#Cons (#TextA "module-state") + #Nil)))))))))] (#Cons [["lux" "doc"] (#TextA "All the information contained within a Lux module.")] default-def-meta-exported))) @@ -556,21 +579,17 @@ default-def-meta-exported))) ## (type: Compiler-Info -## {#compiler-name Text -## #compiler-version Text +## {#compiler-version Text ## #compiler-mode Compiler-Mode}) (_lux_def Compiler-Info (#NamedT ["lux" "Compiler-Info"] - (#ProdT ## "lux;compiler-name" + (#ProdT ## "lux;compiler-version" Text - (#ProdT ## "lux;compiler-version" - Text - ## "lux;compiler-mode" - Compiler-Mode))) - (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "compiler-name") - (#Cons (#TextA "compiler-version") - (#Cons (#TextA "compiler-mode") - #Nil))))] + ## "lux;compiler-mode" + Compiler-Mode)) + (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "compiler-version") + (#Cons (#TextA "compiler-mode") + #Nil)))] (#Cons [["lux" "doc"] (#TextA "Information about the current version and type of compiler that is running.")] default-def-meta-exported))) @@ -1697,7 +1716,7 @@ #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars} state] (_lux_case (get module modules) - (#Some {#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _}) + (#Some {#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _ #module-state _}) (_lux_case (get name defs) (#Some [def-type def-meta def-value]) (_lux_case (get-meta ["lux" "alias"] def-meta) @@ -2206,7 +2225,7 @@ ($' Maybe Macro)) (do Monad [$module (get module modules) - gdef (let' [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _} (_lux_: Module $module)] + gdef (let' [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _ #module-state _} (_lux_: Module $module)] (get name bindings))] (let' [[def-type def-meta def-value] (_lux_: Def gdef)] (_lux_case (get-meta ["lux" "macro?"] def-meta) @@ -3374,7 +3393,7 @@ (-> Ident (Lux [Nat (List Ident) Bool Type])) (do Monad [=module (find-module module) - #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags-table #types types #module-anns _} =module]] + #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags-table #types types #module-anns _ #module-state _} =module]] (case (get name tags-table) (#Some output) (return output) @@ -3397,7 +3416,7 @@ (#NamedT [module name] _) (do Monad [=module (find-module module) - #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _} =module]] + #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _ #module-state _} =module]] (case (get name types) (#Some [tags exported? (#NamedT _ _type)]) (case (resolve-struct-type _type) @@ -3956,7 +3975,7 @@ _ (list)))) - (let [{#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _} =module] + (let [{#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _ #module-state _} =module] defs))] (#Right state (List/join to-alias))) @@ -4022,7 +4041,7 @@ #None #None - (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _}) + (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _ #module-state _}) (case (get v-name defs) #None #None @@ -4041,7 +4060,7 @@ #None (#Left (Text/append "Unknown definition: " (Ident/encode name))) - (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _}) + (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _ #module-state _}) (case (get v-name defs) #None (#Left (Text/append "Unknown definition: " (Ident/encode name))) @@ -4344,7 +4363,7 @@ (-> Text Text (Lux Bool)) (do Monad [module (find-module module-name) - #let [{#module-hash _ #module-aliases _ #defs _ #imports imports #tags _ #types _ #module-anns _} module]] + #let [{#module-hash _ #module-aliases _ #defs _ #imports imports #tags _ #types _ #module-anns _ #module-state _} module]] (wrap (is-member? imports import-name)))) (macro: #export (default tokens state) -- cgit v1.2.3 From 3fa825d4ef98f2bdd9a31202bf04b06b9a1d9daa Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 30 Jan 2017 19:50:38 -0400 Subject: - The data for checking which exceptions are being catched has been moved from the host state to the normal compiler state. --- stdlib/source/lux.lux | 39 ++++++++++++++++++++++----------------- 1 file changed, 22 insertions(+), 17 deletions(-) (limited to 'stdlib') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 19a7b4716..cd16ce35f 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -603,6 +603,7 @@ ## #expected (Maybe Type) ## #seed Nat ## #scope-type-vars (List Nat) +## #catching (List Text) ## #host Void}) (_lux_def Compiler (#NamedT ["lux" "Compiler"] @@ -623,10 +624,13 @@ (#AppT Maybe Type) (#ProdT ## "lux;seed" Nat - (#ProdT ## "lux;scope-type-vars" + (#ProdT ## scope-type-vars (#AppT List Nat) ## "lux;host" - Void)))))))))) + (#ProdT ## catching + (#AppT List Text) + ## "lux;host" + Void))))))))))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "info") (#Cons (#TextA "source") (#Cons (#TextA "cursor") @@ -636,8 +640,9 @@ (#Cons (#TextA "expected") (#Cons (#TextA "seed") (#Cons (#TextA "scope-type-vars") - (#Cons (#TextA "host") - #Nil)))))))))))] + (#Cons (#TextA "catching") + (#Cons (#TextA "host") + #Nil))))))))))))] (#Cons [["lux" "doc"] (#TextA "Represents the state of the Lux compiler during a run. It is provided to macros during their invocation, so they can access compiler data. @@ -1714,7 +1719,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} state] + #scope-type-vars scope-type-vars #catching _} state] (_lux_case (get module modules) (#Some {#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _ #module-state _}) (_lux_case (get name defs) @@ -1873,7 +1878,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching _} (_lux_case (reverse scopes) (#Cons {#name (#;Cons module-name #Nil) #inner-closures _ #locals _ #closure _} _) (#Right [state module-name]) @@ -2273,7 +2278,7 @@ #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching _} (#Right state (find-macro' modules current-module module name))))))) (def:''' (macro? ident) @@ -2528,12 +2533,12 @@ #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching catching} (#Right {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed (n.+ +1 seed) #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching catching} (symbol$ ["" ($_ Text/append "__gensym__" prefix (->Text seed))])))) (macro:' #export (Rec tokens) @@ -3375,7 +3380,7 @@ (let [{#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} state] + #scope-type-vars scope-type-vars #catching _} state] (case (get name modules) (#Some module) (#Right state module) @@ -3438,7 +3443,7 @@ (let [{#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} state] + #scope-type-vars scope-type-vars #catching _} state] (case expected (#Some type) (#Right state type) @@ -3961,7 +3966,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching _} modules)] (case (get module modules) (#Some =module) @@ -4016,7 +4021,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching _} (find (: (-> Scope (Maybe Type)) (lambda [env] (case env @@ -4036,7 +4041,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} state] + #scope-type-vars scope-type-vars #catching _} state] (case (get v-prefix modules) #None #None @@ -4055,7 +4060,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} state] + #scope-type-vars scope-type-vars #catching _} state] (case (get v-prefix modules) #None (#Left (Text/append "Unknown definition: " (Ident/encode name))) @@ -5409,7 +5414,7 @@ {#info info #source source #modules modules #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor - #scope-type-vars scope-type-vars} + #scope-type-vars scope-type-vars #catching _} (#Right state scope-type-vars) )) @@ -5518,7 +5523,7 @@ (let [{#;info info #;source source #;modules modules #;scopes scopes #;type-vars types #;host host #;seed seed #;expected expected #;cursor cursor - #;scope-type-vars scope-type-vars} state] + #;scope-type-vars scope-type-vars #catching _} state] (#;Right [state cursor])))) (macro: #export (with-cursor tokens) -- cgit v1.2.3 From 8003120870b877264afcfc5bc785453ae55e2a7b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 5 Feb 2017 23:12:18 -0400 Subject: - Added support for compiling _lux_proc (some procedures). - Added support for compiling (some) procedures, captured-variables, iteration, if-expressions and get-expressions. - Fixed some bugs. --- stdlib/source/lux.lux | 298 +++++++++++++++++----------------- stdlib/source/lux/control/comonad.lux | 11 +- stdlib/source/lux/control/monad.lux | 13 +- stdlib/source/lux/data/coll/list.lux | 2 +- stdlib/source/lux/io.lux | 2 +- stdlib/source/lux/macro/ast.lux | 2 +- 6 files changed, 163 insertions(+), 165 deletions(-) (limited to 'stdlib') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index cd16ce35f..1c74cac80 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -323,11 +323,11 @@ ## (type: Cursor ## {#module Text -## #line Int -## #column Int}) +## #line Nat +## #column Nat}) (_lux_def Cursor (#NamedT ["lux" "Cursor"] - (#ProdT Text (#ProdT Int Int))) + (#ProdT Text (#ProdT Nat Nat))) (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "module") (#Cons (#TextA "line") (#Cons (#TextA "column") @@ -673,16 +673,10 @@ default-def-meta-exported)) ## Base functions & macros -## (def: _cursor -## Cursor -## ["" -1 -1]) (_lux_def _cursor - (_lux_: Cursor ["" -1 -1]) + (_lux_: Cursor ["" +0 +0]) #Nil) -## (def: (_meta data) -## (-> (AST' (Meta Cursor)) AST) -## [["" -1 -1] data]) (_lux_def _meta (_lux_: (#LambdaT (#AppT AST' (#AppT Meta Cursor)) @@ -691,11 +685,6 @@ [_cursor data])) #Nil) -## (def: (return x) -## (All [a] -## (-> a Compiler -## (Either Text [Compiler a]))) -## ...) (_lux_def return (_lux_: (#UnivQ #Nil (#LambdaT (#BoundT +1) @@ -708,11 +697,6 @@ (#Right state val)))) #Nil) -## (def: (fail msg) -## (All [a] -## (-> Text Compiler -## (Either Text [Compiler a]))) -## ...) (_lux_def fail (_lux_: (#UnivQ #Nil (#LambdaT Text @@ -1044,7 +1028,7 @@ (def:'' (Text/= x y) #Nil (#LambdaT Text (#LambdaT Text Bool)) - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [x y])) + (_lux_proc ["text" "="] [x y])) (def:'' (get-rep key env) #Nil @@ -1157,7 +1141,7 @@ #Nil (#UnivQ #Nil (#LambdaT ($' List (#BoundT +1)) Int)) - (fold (lambda'' [_ acc] (_lux_proc ["jvm" "ladd"] [1 acc])) 0 list)) + (fold (lambda'' [_ acc] (_lux_proc ["int" "+"] [1 acc])) 0 list)) (macro:' #export (All tokens) (#Cons [["lux" "doc"] (#TextA "## Universal quantification. @@ -1469,7 +1453,7 @@ (def:''' (wrap-meta content) #Nil (-> AST AST) - (tuple$ (list (tuple$ (list (text$ "") (int$ -1) (int$ -1))) + (tuple$ (list (tuple$ (list (text$ "") (nat$ +0) (nat$ +0))) content))) (def:''' (untemplate-list tokens) @@ -1685,7 +1669,7 @@ (def:''' (Text/append x y) #Nil (-> Text Text Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y])) + (_lux_proc ["text" "append"] [x y])) (def:''' (Ident/encode ident) #Nil @@ -1931,12 +1915,12 @@ (macro:' #export (|> tokens) (list [["lux" "doc"] (#TextA "## Piping macro. - (|> elems (map ->Text) (interpose \" \") (fold Text/append \"\")) + (|> elems (map Int/encode) (interpose \" \") (fold Text/append \"\")) ## => (fold Text/append \"\" (interpose \" \" - (map ->Text elems)))")]) + (map Int/encode elems)))")]) (_lux_case tokens (#Cons [init apps]) (return (list (fold (_lux_: (-> AST AST AST) @@ -1958,12 +1942,12 @@ (macro:' #export (<| tokens) (list [["lux" "doc"] (#TextA "## Reverse piping macro. - (<| (fold Text/append \"\") (interpose \" \") (map ->Text) elems) + (<| (fold Text/append \"\") (interpose \" \") (map Int/encode) elems) ## => (fold Text/append \"\" (interpose \" \" - (map ->Text elems)))")]) + (map Int/encode elems)))")]) (_lux_case (reverse tokens) (#Cons [init apps]) (return (list (fold (_lux_: (-> AST AST AST) @@ -2077,12 +2061,46 @@ (def:''' (i= x y) #Nil (-> Int Int Bool) - (_lux_proc ["jvm" "leq"] [x y])) + (_lux_proc ["int" "="] [x y])) -(def:''' (->Text x) +(def:''' (Bool/encode x) #Nil - (-> (host java.lang.Object) Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x])) + (-> Bool Text) + (if x "true" "false")) + +(def:''' (Nat/encode x) + #Nil + (-> Nat Text) + (_lux_proc ["nat" "encode"] [x])) + +(def:''' (Int/encode x) + #Nil + (-> Int Text) + (_lux_proc ["int" "encode"] [x])) + +(def:''' (Deg/encode x) + #Nil + (-> Deg Text) + (_lux_proc ["deg" "encode"] [x])) + +(def:''' (Real/encode x) + #Nil + (-> Real Text) + (_lux_proc ["real" "encode"] [x])) + +(def:''' (Char/encode x) + #Nil + (-> Char Text) + (let' [as-text (_lux_case x + #"\t" "\\t" + #"\b" "\\b" + #"\n" "\\n" + #"\r" "\\r" + #"\f" "\\f" + #"\"" "\\\"" + #"\\" "\\\\" + _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] + ($_ Text/append "#\"" as-text "\""))) (macro:' #export (do-template tokens) (list [["lux" "doc"] (#TextA "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary. @@ -2105,7 +2123,7 @@ (|> data' (join-map (. apply (make-env bindings'))) return) - (fail (Text/append "Irregular arguments vectors for do-template. Expected size " (->Text num-bindings))))) + (fail (Text/append "Irregular arguments vectors for do-template. Expected size " (Int/encode num-bindings))))) _ (fail "Wrong syntax for do-template")) @@ -2113,47 +2131,47 @@ _ (fail "Wrong syntax for do-template"))) -(do-template [ <=-name> <=> +(do-template [ <=-name> <<-doc> <<=-doc> <>-doc> <>=-doc>] [(def:''' #export (<=-name> test subject) (list [["lux" "doc"] (#TextA )]) (-> Bool) - (_lux_proc [ <=>] [subject test])) + (_lux_proc [ "="] [subject test])) (def:''' #export ( test subject) (list [["lux" "doc"] (#TextA <<-doc>)]) (-> Bool) - (_lux_proc [ ] [subject test])) + (_lux_proc [ "<"] [subject test])) (def:''' #export ( test subject) (list [["lux" "doc"] (#TextA <<=-doc>)]) (-> Bool) - (if (_lux_proc [ ] [subject test]) + (if (_lux_proc [ "<"] [subject test]) true - (_lux_proc [ <=>] [subject test]))) + (_lux_proc [ "="] [subject test]))) (def:''' #export ( test subject) (list [["lux" "doc"] (#TextA <>-doc>)]) (-> Bool) - (_lux_proc [ ] [test subject])) + (_lux_proc [ "<"] [test subject])) (def:''' #export ( test subject) (list [["lux" "doc"] (#TextA <>=-doc>)]) (-> Bool) - (if (_lux_proc [ ] [test subject]) + (if (_lux_proc [ "<"] [test subject]) true - (_lux_proc [ <=>] [subject test])))] + (_lux_proc [ "="] [subject test])))] - [ Nat "nat" n.= "=" n.< n.<= "<" n.> n.>= + [ Nat "nat" n.= n.< n.<= n.> n.>= "Natural equality." "Natural less-than." "Natural less-than-equal." "Natural greater-than." "Natural greater-than-equal."] - [ Int "jvm" i.= "leq" i.< i.<= "llt" i.> i.>= + [ Int "int" i.= i.< i.<= i.> i.>= "Integer equality." "Integer less-than." "Integer less-than-equal." "Integer greater-than." "Integer greater-than-equal."] - [Deg "deg" d.= "=" d.< d.<= "<" d.> d.>= + [ Deg "deg" d.= d.< d.<= d.> d.>= "Degree equality." "Degree less-than." "Degree less-than-equal." "Degree greater-than." "Degree greater-than-equal."] - [Real "jvm" r.= "deq" r.< r.<= "dlt" r.> r.>= + [Real "real" r.= r.< r.<= r.> r.>= "Real equality." "Real less-than." "Real less-than-equal." "Real greater-than." "Real greater-than-equal."] ) @@ -2163,29 +2181,29 @@ (-> ) (_lux_proc [subject param]))] - [ Nat n.+ ["nat" "+"] "Nat(ural) addition."] - [ Nat n.- ["nat" "-"] "Nat(ural) substraction."] - [ Nat n.* ["nat" "*"] "Nat(ural) multiplication."] - [ Nat n./ ["nat" "/"] "Nat(ural) division."] - [ Nat n.% ["nat" "%"] "Nat(ural) remainder."] + [ Nat n.+ [ "nat" "+"] "Nat(ural) addition."] + [ Nat n.- [ "nat" "-"] "Nat(ural) substraction."] + [ Nat n.* [ "nat" "*"] "Nat(ural) multiplication."] + [ Nat n./ [ "nat" "/"] "Nat(ural) division."] + [ Nat n.% [ "nat" "%"] "Nat(ural) remainder."] - [ Int i.+ ["jvm" "ladd"] "Int(eger) addition."] - [ Int i.- ["jvm" "lsub"] "Int(eger) substraction."] - [ Int i.* ["jvm" "lmul"] "Int(eger) multiplication."] - [ Int i./ ["jvm" "ldiv"] "Int(eger) division."] - [ Int i.% ["jvm" "lrem"] "Int(eger) remainder."] - - [Deg d.+ ["deg" "+"] "Deg(ree) addition."] - [Deg d.- ["deg" "-"] "Deg(ree) substraction."] - [Deg d.* ["deg" "*"] "Deg(ree) multiplication."] - [Deg d./ ["deg" "/"] "Deg(ree) division."] - [Deg d.% ["deg" "%"] "Deg(ree) remainder."] + [ Int i.+ [ "int" "+"] "Int(eger) addition."] + [ Int i.- [ "int" "-"] "Int(eger) substraction."] + [ Int i.* [ "int" "*"] "Int(eger) multiplication."] + [ Int i./ [ "int" "/"] "Int(eger) division."] + [ Int i.% [ "int" "%"] "Int(eger) remainder."] + + [ Deg d.+ [ "deg" "+"] "Deg(ree) addition."] + [ Deg d.- [ "deg" "-"] "Deg(ree) substraction."] + [ Deg d.* [ "deg" "*"] "Deg(ree) multiplication."] + [ Deg d./ [ "deg" "/"] "Deg(ree) division."] + [ Deg d.% [ "deg" "%"] "Deg(ree) remainder."] - [Real r.+ ["jvm" "dadd"] "Real addition."] - [Real r.- ["jvm" "dsub"] "Real substraction."] - [Real r.* ["jvm" "dmul"] "Real multiplication."] - [Real r./ ["jvm" "ddiv"] "Real division."] - [Real r.% ["jvm" "drem"] "Real remainder."] + [Real r.+ ["real" "+"] "Real addition."] + [Real r.- ["real" "-"] "Real substraction."] + [Real r.* ["real" "*"] "Real multiplication."] + [Real r./ ["real" "/"] "Real division."] + [Real r.% ["real" "%"] "Real remainder."] ) (do-template [ ] @@ -2196,14 +2214,14 @@ left right))] - [n.min Nat n.< "Nat(ural) minimum."] - [n.max Nat n.> "Nat(ural) maximum."] + [n.min Nat n.< "Nat(ural) minimum."] + [n.max Nat n.> "Nat(ural) maximum."] - [i.min Int i.< "Int(eger) minimum."] - [i.max Int i.> "Int(eger) maximum."] + [i.min Int i.< "Int(eger) minimum."] + [i.max Int i.> "Int(eger) maximum."] - [d.min Deg d.< "Deg(ree) minimum."] - [d.max Deg d.> "Deg(ree) maximum."] + [d.min Deg d.< "Deg(ree) minimum."] + [d.max Deg d.> "Deg(ree) maximum."] [r.min Real r.< "Real minimum."] [r.max Real r.> "Real minimum."] @@ -2530,16 +2548,16 @@ (-> Text ($' Lux AST)) (_lux_case state {#info info #source source #modules modules - #scopes scopes #type-vars types #host host + #scopes scopes #type-vars types #host host #seed seed #expected expected #cursor cursor #scope-type-vars scope-type-vars #catching catching} (#Right {#info info #source source #modules modules - #scopes scopes #type-vars types #host host + #scopes scopes #type-vars types #host host #seed (n.+ +1 seed) #expected expected #cursor cursor #scope-type-vars scope-type-vars #catching catching} - (symbol$ ["" ($_ Text/append "__gensym__" prefix (->Text seed))])))) + (symbol$ ["" ($_ Text/append "__gensym__" prefix (Nat/encode seed))])))) (macro:' #export (Rec tokens) (list [["lux" "doc"] (#TextA "## Parameter-less recursive types. @@ -2622,36 +2640,26 @@ (let' [[left right] pair] (list left right))) -(def:''' (Nat->Text x) - #Nil - (-> Nat Text) - (_lux_proc ["nat" "encode"] [x])) - -(def:''' (Deg->Text x) - #Nil - (-> Deg Text) - (_lux_proc ["deg" "encode"] [x])) - (def:' (ast-to-text ast) (-> AST Text) (_lux_case ast [_ (#BoolS value)] - (->Text value) + (Bool/encode value) [_ (#NatS value)] - (Nat->Text value) + (Nat/encode value) [_ (#IntS value)] - (->Text value) + (Int/encode value) [_ (#DegS value)] - (Deg->Text value) + (Deg/encode value) [_ (#RealS value)] - (->Text value) + (Real/encode value) [_ (#CharS value)] - ($_ Text/append "#" "\"" (->Text value) "\"") + ($_ Text/append "#" "\"" (Char/encode value) "\"") [_ (#TextS value)] ($_ Text/append "\"" value "\"") @@ -4158,13 +4166,13 @@ ($_ Text/append "(-> " (|> (flatten-lambda type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")") (#BoundT id) - (Nat->Text id) + (Nat/encode id) (#VarT id) - ($_ Text/append "⌈v:" (->Text id) "⌋") + ($_ Text/append "⌈v:" (Nat/encode id) "⌋") (#ExT id) - ($_ Text/append "⟨e:" (->Text id) "⟩") + ($_ Text/append "⟨e:" (Nat/encode id) "⟩") (#UnivQ env body) ($_ Text/append "(All " (Type/show body) ")") @@ -4354,12 +4362,12 @@ (macro: #export (|>. tokens) {#;doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it. - (|> (map ->Text) (interpose \" \") (fold Text/append \"\")) + (|> (map Int/encode) (interpose \" \") (fold Text/append \"\")) ## => (lambda [] (fold Text/append \"\" (interpose \" \" - (map ->Text ))))"} + (map Int/encode ))))"} (do Monad [g!arg (gensym "arg")] (return (list (` (lambda [(~ g!arg)] (|> (~ g!arg) (~@ tokens)))))))) @@ -4379,7 +4387,7 @@ (default 20 #;None) => 20"} (case tokens (^ (list else maybe)) - (let [g!temp (: AST [["" -1 -1] (#;SymbolS ["" ""])]) + (let [g!temp (: AST [_cursor (#;SymbolS ["" ""])]) code (` (case (~ maybe) (#;Some (~ g!temp)) (~ g!temp) @@ -4793,7 +4801,7 @@ ) (def: (find-baseline-column ast) - (-> AST Int) + (-> AST Nat) (case ast (^template [] [[_ _ column] ( _)] @@ -4810,12 +4818,12 @@ (^template [] [[_ _ column] ( parts)] - (fold i.min column (map find-baseline-column parts))) + (fold n.min column (map find-baseline-column parts))) ([#FormS] [#TupleS]) [[_ _ column] (#RecordS pairs)] - (fold i.min column + (fold n.min column (List/append (map (. find-baseline-column first) pairs) (map (. find-baseline-column second) pairs))) )) @@ -4833,19 +4841,6 @@ _ (#Doc-Example ast))) -(def: (Char/encode x) - (-> Char Text) - (let [as-text (case x - #"\t" "\\t" - #"\b" "\\b" - #"\n" "\\n" - #"\r" "\\r" - #"\f" "\\f" - #"\"" "\\\"" - #"\\" "\\\\" - _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] - ($_ Text/append "#\"" as-text "\""))) - (def: (Text/encode original) (-> Text Text) (let [escaped (|> original @@ -4865,16 +4860,28 @@ (-> ) ( value))] - [i.inc i.+ 1 Int "Increment function."] - [i.dec i.- 1 Int "Decrement function."] - [n.inc n.+ +1 Nat "Increment function."] - [n.dec n.- +1 Nat "Decrement function."] + [i.inc i.+ 1 Int "[Int] Increment function."] + [i.dec i.- 1 Int "[Int] Decrement function."] + [n.inc n.+ +1 Nat "[Nat] Increment function."] + [n.dec n.- +1 Nat "[Nat] Decrement function."] ) -(def: tag->Text +(def: Tag/encode (-> Ident Text) (. (Text/append "#") Ident/encode)) +(do-template [ ] + [(def: #export ( input) + (-> ) + (_lux_proc [input]))] + + [int-to-nat ["int" "to-nat"] Int Nat] + [nat-to-int ["nat" "to-int"] Nat Int] + + [real-to-deg ["real" "to-deg"] Real Deg] + [deg-to-real ["deg" "to-real"] Deg Real] + ) + (def: (repeat n x) (All [a] (-> Int a (List a))) (if (i.> 0 n) @@ -4882,17 +4889,18 @@ #;Nil)) (def: (cursor-padding baseline [_ old-line old-column] [_ new-line new-column]) - (-> Int Cursor Cursor Text) - (if (i.= old-line new-line) - (Text/join (repeat (i.- old-column new-column) " ")) - (let [extra-lines (Text/join (repeat (i.- old-line new-line) "\n")) - space-padding (Text/join (repeat (i.- baseline new-column) " "))] + (-> Nat Cursor Cursor Text) + (if (n.= old-line new-line) + (Text/join (repeat (nat-to-int (n.- old-column new-column)) " ")) + (let [extra-lines (Text/join (repeat (nat-to-int (n.- old-line new-line)) "\n")) + space-padding (Text/join (repeat (nat-to-int (n.- baseline new-column)) " "))] (Text/append extra-lines space-padding)))) (def: (Text/size x) - (-> Text Int) - (_lux_proc ["jvm" "i2l"] - [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])])) + (-> Text Nat) + (:! Nat + (_lux_proc ["jvm" "i2l"] + [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])]))) (def: (Text/trim x) (-> Text Text) @@ -4900,18 +4908,18 @@ (def: (update-cursor [file line column] ast-text) (-> Cursor Text Cursor) - [file line (i.+ column (Text/size ast-text))]) + [file line (n.+ column (Text/size ast-text))]) (def: (delim-update-cursor [file line column]) (-> Cursor Cursor) - [file line (i.inc column)]) + [file line (n.inc column)]) (def: rejoin-all-pairs (-> (List [AST AST]) (List AST)) (. List/join (map rejoin-pair))) (def: (doc-example->Text prev-cursor baseline example) - (-> Cursor Int AST [Cursor Text]) + (-> Cursor Nat AST [Cursor Text]) (case example (^template [ ] [new-cursor ( value)] @@ -4919,15 +4927,15 @@ [(update-cursor new-cursor as-text) (Text/append (cursor-padding baseline prev-cursor new-cursor) as-text)])) - ([#BoolS ->Text] - [#NatS Nat->Text] - [#IntS ->Text] - [#DegS Deg->Text] - [#RealS ->Text] + ([#BoolS Bool/encode] + [#NatS Nat/encode] + [#IntS Int/encode] + [#DegS Deg/encode] + [#RealS Real/encode] [#CharS Char/encode] [#TextS Text/encode] [#SymbolS Ident/encode] - [#TagS tag->Text]) + [#TagS Tag/encode]) (^template [ ] [group-cursor ( parts)] @@ -4947,7 +4955,7 @@ )) (def: (with-baseline baseline [file line column]) - (-> Int Cursor Cursor) + (-> Nat Cursor Cursor) [file line baseline]) (def: (doc-fragment->Text fragment) @@ -5166,7 +5174,7 @@ (compare (:: AST/encode show )) (compare true (:: Eq = ))] - [(bool true) "true" [["" -1 -1] (#;BoolS true)]] + [(bool true) "true" [_ (#;BoolS true)]] [(bool false) "false" [_ (#;BoolS false)]] [(int 123) "123" [_ (#;IntS 123)]] [(real 123.0) "123.0" [_ (#;RealS 123.0)]] @@ -5447,7 +5455,7 @@ (wrap (list (` (#ExT (~ (nat$ var-id)))))) #;None - (fail (Text/append "Indexed-type doesn't exist: " (->Text idx))))) + (fail (Text/append "Indexed-type doesn't exist: " (Nat/encode idx))))) _ (fail "Wrong syntax for $"))) @@ -5537,7 +5545,7 @@ (do Monad [cursor get-cursor] (let [[module line column] cursor - cursor-prefix ($_ hack_Text/append "[" module "," (->Text line) "," (->Text column) "] ")] + cursor-prefix ($_ hack_Text/append "[" module "," (Nat/encode line) "," (Nat/encode column) "] ")] (wrap (list (` (hack_Text/append (~ (text$ cursor-prefix)) (~ message))))))) _ @@ -5591,18 +5599,6 @@ _ (fail "Wrong syntax for @post"))) -(do-template [ ] - [(def: #export ( input) - (-> ) - (_lux_proc [input]))] - - [int-to-nat ["int" "to-nat"] Int Nat] - [nat-to-int ["nat" "to-int"] Nat Int] - - [real-to-deg ["real" "to-deg"] Real Deg] - [deg-to-real ["deg" "to-real"] Deg Real] - ) - (macro: #export (type-of tokens) {#;doc (doc "Generates the type corresponding to a given definition or variable." (let [my-num (: Int 123)] diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux index f78ffea17..5ed443040 100644 --- a/stdlib/source/lux/control/comonad.lux +++ b/stdlib/source/lux/control/comonad.lux @@ -18,6 +18,8 @@ split)) ## [Syntax] +(def: _cursor Cursor ["" +0 +0]) + (macro: #export (be tokens state) {#;doc (doc "A co-monadic parallel to the \"do\" macro." (let [square (lambda [n] (i.* n n))] @@ -26,9 +28,8 @@ (square (head inputs)))))} (case tokens (#;Cons comonad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) - (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])]) - g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) - g!split (: AST [["" -1 -1] (#;SymbolS ["" " split "])]) + (let [g!map (: AST [_cursor (#;SymbolS ["" " map "])]) + g!split (: AST [_cursor (#;SymbolS ["" " split "])]) body' (fold (: (-> [AST AST] AST AST) (lambda [binding body'] (let [[var value] binding] @@ -42,8 +43,8 @@ body (reverse (as-pairs bindings)))] (#;Right [state (#;Cons (` (;_lux_case (~ comonad) - (~ g!@) - (;_lux_case (~ g!@) + (~' @) + (;_lux_case (~' @) {#functor {#F;map (~ g!map)} #unwrap (~' unwrap) #split (~ g!split)} (~ body')))) #;Nil)])) diff --git a/stdlib/source/lux/control/monad.lux b/stdlib/source/lux/control/monad.lux index 5c540791a..a6d0d5988 100644 --- a/stdlib/source/lux/control/monad.lux +++ b/stdlib/source/lux/control/monad.lux @@ -49,6 +49,8 @@ join)) ## [Syntax] +(def: _cursor Cursor ["" +0 +0]) + (macro: #export (do tokens state) {#;doc (doc "Macro for easy concatenation of monadic operations." (do Monad @@ -57,10 +59,9 @@ (wrap (f3 z))))} (case tokens (#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) - (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])]) - g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) - g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])]) - g!apply (: AST [["" -1 -1] (#;SymbolS ["" " apply "])]) + (let [g!map (: AST [_cursor (#;SymbolS ["" " map "])]) + g!join (: AST [_cursor (#;SymbolS ["" " join "])]) + g!apply (: AST [_cursor (#;SymbolS ["" " apply "])]) body' (fold (: (-> [AST AST] AST AST) (lambda [binding body'] (let [[var value] binding] @@ -74,8 +75,8 @@ body (reverse (as-pairs bindings)))] (#;Right [state (#;Cons (` (;_lux_case (~ monad) - (~ g!@) - (;_lux_case (~ g!@) + (~' @) + (;_lux_case (~' @) {#applicative {#A;functor {#F;map (~ g!map)} #A;wrap (~' wrap) #A;apply (~ g!apply)} diff --git a/stdlib/source/lux/data/coll/list.lux b/stdlib/source/lux/data/coll/list.lux index 4d9d9c270..5f2ef3984 100644 --- a/stdlib/source/lux/data/coll/list.lux +++ b/stdlib/source/lux/data/coll/list.lux @@ -335,7 +335,7 @@ ## [Syntax] (def: (symbol$ name) (-> Text AST) - [["" -1 -1] (#;SymbolS "" name)]) + [["" +0 +0] (#;SymbolS "" name)]) (macro: #export (zip tokens state) {#;doc (doc "Create list zippers with the specified number of input lists." diff --git a/stdlib/source/lux/io.lux b/stdlib/source/lux/io.lux index 93c01ee85..8a9e6bb9e 100644 --- a/stdlib/source/lux/io.lux +++ b/stdlib/source/lux/io.lux @@ -19,7 +19,7 @@ "Some value...")))} (case tokens (^ (list value)) - (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])] + (let [blank (: AST [["" +0 +0] (#;SymbolS ["" ""])])] (#;Right [state (list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) _ diff --git a/stdlib/source/lux/macro/ast.lux b/stdlib/source/lux/macro/ast.lux index 49d68b5c3..6647307dd 100644 --- a/stdlib/source/lux/macro/ast.lux +++ b/stdlib/source/lux/macro/ast.lux @@ -27,7 +27,7 @@ ## (Meta Cursor (AST' (Meta Cursor)))) ## [Utils] -(def: _cursor Cursor ["" -1 -1]) +(def: _cursor Cursor ["" +0 +0]) ## [Functions] (do-template [ ] -- cgit v1.2.3 From 12dcb6e964e0c54f4001413bc62b8bcb526fa9c4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 11 Feb 2017 19:58:26 -0400 Subject: - Now doing common array analysis/compilation. - Now doing common io/log! analysis/compilation. - Now doing common char/to-text analysis/compilation. - Expanded compilation of procedures in JS. - Expanded LuxRT in JS. - Fixed some bugs. --- stdlib/source/lux.lux | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) (limited to 'stdlib') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 1c74cac80..06c0fd2fd 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -2099,7 +2099,7 @@ #"\f" "\\f" #"\"" "\\\"" #"\\" "\\\\" - _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))] + _ (_lux_proc ["char" "to-text"] [x]))] ($_ Text/append "#\"" as-text "\""))) (macro:' #export (do-template tokens) @@ -2241,6 +2241,13 @@ (-> Bool Bool) (if x false true)) +(def:''' #export (log! message) + (list [["lux" "doc"] (#TextA "Logs message to standard output. + + Useful for debugging.")]) + (-> Text Unit) + (_lux_proc ["io" "log!"] [message])) + (def:''' (find-macro' modules current-module module name) #Nil (-> ($' List (& Text Module)) @@ -2998,14 +3005,6 @@ (#;Some (#;Right [])) (list (' #hidden)))) -(def:''' #export (log! message) - (list [["lux" "doc"] (#TextA "Logs message to standard output. - - Useful for debugging.")]) - (-> Text Unit) - (_lux_proc ["jvm" "invokevirtual:java.io.PrintStream:println:java.lang.String"] - [(_lux_proc ["jvm" "getstatic:java.lang.System:out"] []) message])) - (macro:' #export (def: tokens) (list [["lux" "doc"] (#TextA "## Defines global constants/functions. (def: (rejoin-pair pair) -- cgit v1.2.3 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/source/lux.lux | 162 ++++++++++++++++++---------------- stdlib/source/lux/data/number.lux | 105 +++++++++------------- stdlib/source/lux/data/text.lux | 8 +- stdlib/source/lux/math/complex.lux | 8 +- stdlib/test/test/lux.lux | 16 ++-- stdlib/test/test/lux/data/text.lux | 8 +- stdlib/test/test/lux/math/complex.lux | 16 ++-- 7 files changed, 156 insertions(+), 167 deletions(-) (limited to 'stdlib') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 06c0fd2fd..c6018398b 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -1666,6 +1666,13 @@ (#Cons [[k' v] dict']) (#Cons [[k' v'] (put k v dict')])))) +(def:''' #export (log! message) + (list [["lux" "doc"] (#TextA "Logs message to standard output. + + Useful for debugging.")]) + (-> Text Unit) + (_lux_proc ["io" "log"] [message])) + (def:''' (Text/append x y) #Nil (-> Text Text Text) @@ -2241,13 +2248,6 @@ (-> Bool Bool) (if x false true)) -(def:''' #export (log! message) - (list [["lux" "doc"] (#TextA "Logs message to standard output. - - Useful for debugging.")]) - (-> Text Unit) - (_lux_proc ["io" "log!"] [message])) - (def:''' (find-macro' modules current-module module name) #Nil (-> ($' List (& Text Module)) @@ -2568,7 +2568,7 @@ (macro:' #export (Rec tokens) (list [["lux" "doc"] (#TextA "## Parameter-less recursive types. - ## A name has to be given to the whole type, to use it within it's body. + ## A name has to be given to the whole type, to use it within its body. (Rec Self [Int (List Self)])")]) (_lux_case tokens @@ -3223,42 +3223,81 @@ (#Some y)))) (def: (last-index-of part text) - (-> Text Text Int) - (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:lastIndexOf:java.lang.String"] [text part])])) + (-> Text Text (Maybe Nat)) + (_lux_proc ["text" "last-index"] [text part])) (def: (index-of part text) - (-> Text Text Int) - (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:indexOf:java.lang.String"] [text part])])) + (-> Text Text (Maybe Nat)) + (_lux_proc ["text" "index"] [text part])) + +(def: (clip1 from text) + (-> Nat Text (Maybe Text)) + (_lux_proc ["text" "clip"] [text from (_lux_proc ["text" "size"] [text])])) + +(def: (clip2 from to text) + (-> Nat Nat Text (Maybe Text)) + (_lux_proc ["text" "clip"] [text from to])) + +(def: #export (error! message) + {#;doc "## Causes an error, with the given error message. + (error! \"OH NO!\")"} + (-> Text Bottom) + (_lux_proc ["io" "error"] [message])) -(def: (substring1 idx text) - (-> Int Text Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [text (_lux_proc ["jvm" "l2i"] [idx])])) +(macro: #export (default tokens state) + {#;doc "## Allows you to provide a default value that will be used + ## if a (Maybe x) value turns out to be #;None. + (default 20 (#;Some 10)) => 10 -(def: (substring2 idx1 idx2 text) - (-> Int Int Text Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [text (_lux_proc ["jvm" "l2i"] [idx1]) (_lux_proc ["jvm" "l2i"] [idx2])])) + (default 20 #;None) => 20"} + (case tokens + (^ (list else maybe)) + (let [g!temp (: AST [_cursor (#;SymbolS ["" ""])]) + code (` (case (~ maybe) + (#;Some (~ g!temp)) + (~ g!temp) + + #;None + (~ else)))] + (#;Right [state (list code)])) + + _ + (#;Left "Wrong syntax for ?"))) (def: (split-text splitter input) (-> Text Text (List Text)) - (let [idx (index-of splitter input)] - (if (i.< 0 idx) - (#Cons input #Nil) - (#Cons (substring2 0 idx input) - (split-text splitter (substring1 (i.+ 1 idx) input)))))) + (case (index-of splitter input) + #;None + (#Cons input #Nil) + + (#;Some idx) + (#Cons (default (error! "UNDEFINED") + (clip2 +0 idx input)) + (split-text splitter + (default (error! "UNDEFINED") + (clip1 (n.+ +1 idx) input)))))) (def: (split-module-contexts module) (-> Text (List Text)) - (#Cons module (let [idx (last-index-of "/" module)] - (if (i.< 0 idx) - #Nil - (split-module-contexts (substring2 0 idx module)))))) + (#Cons module (case (last-index-of "/" module) + #;None + #Nil + + (#;Some idx) + (split-module-contexts (default (error! "UNDEFINED") + (clip2 +0 idx module)))))) (def: (split-module module) (-> Text (List Text)) - (let [idx (index-of "/" module)] - (if (i.< 0 idx) - (list module) - (list& (substring2 0 idx module) (split-module (substring1 (i.+ 1 idx) module)))))) + (case (index-of "/" module) + #;None + (list module) + + (#;Some idx) + (list& (default (error! "UNDEFINED") + (clip2 +0 idx module)) + (split-module (default (error! "UNDEFINED") + (clip1 (n.+ +1 idx) module)))))) (def: (nth idx xs) (All [a] @@ -3881,22 +3920,22 @@ (def: (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])) (def: (clean-module module) (-> Text (Lux Text)) (do Monad - [module-name current-module-name] + [current-module current-module-name] (case (split-module module) (^ (list& "." parts)) - (return (|> (list& module-name parts) (interpose "/") reverse (fold Text/append ""))) + (return (|> (list& current-module parts) (interpose "/") reverse (fold Text/append ""))) parts (let [[ups parts'] (split-with (Text/= "..") parts) num-ups (length ups)] (if (i.= num-ups 0) (return module) - (case (nth num-ups (split-module-contexts module-name)) + (case (nth num-ups (split-module-contexts current-module)) #None (fail (Text/append "Can't clean module: " module)) @@ -4378,26 +4417,6 @@ #let [{#module-hash _ #module-aliases _ #defs _ #imports imports #tags _ #types _ #module-anns _ #module-state _} module]] (wrap (is-member? imports import-name)))) -(macro: #export (default tokens state) - {#;doc "## Allows you to provide a default value that will be used - ## if a (Maybe x) value turns out to be #;None. - (default 20 (#;Some 10)) => 10 - - (default 20 #;None) => 20"} - (case tokens - (^ (list else maybe)) - (let [g!temp (: AST [_cursor (#;SymbolS ["" ""])]) - code (` (case (~ maybe) - (#;Some (~ g!temp)) - (~ g!temp) - - #;None - (~ else)))] - (#;Right [state (list code)])) - - _ - (#;Left "Wrong syntax for ?"))) - (def: (read-refer module-name options) (-> Text (List AST) (Lux Refer)) (do Monad @@ -4790,13 +4809,13 @@ _ (fail "Wrong syntax for ^template"))) -(do-template [ ] +(do-template [ ] [(def: #export ( n) (-> ) - (_lux_proc ["jvm" ] [n]))] + (_lux_proc [n]))] - [real-to-int Real Int "d2l"] - [int-to-real Int Real "l2d"] + [real-to-int Real Int ["real" "to-int"]] + [int-to-real Int Real ["int" "to-real"]] ) (def: (find-baseline-column ast) @@ -4874,11 +4893,10 @@ (-> ) (_lux_proc [input]))] - [int-to-nat ["int" "to-nat"] Int Nat] - [nat-to-int ["nat" "to-int"] Nat Int] - + [int-to-nat ["int" "to-nat"] Int Nat] + [nat-to-int ["nat" "to-int"] Nat Int] [real-to-deg ["real" "to-deg"] Real Deg] - [deg-to-real ["deg" "to-real"] Deg Real] + [deg-to-real ["deg" "to-real"] Deg Real] ) (def: (repeat n x) @@ -4897,13 +4915,11 @@ (def: (Text/size x) (-> Text Nat) - (:! Nat - (_lux_proc ["jvm" "i2l"] - [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])]))) + (_lux_proc ["text" "size"] [x])) (def: (Text/trim x) (-> Text Text) - (_lux_proc ["jvm" "invokevirtual:java.lang.String:trim:"] [x])) + (_lux_proc ["text" "trim"] [x])) (def: (update-cursor [file line column] ast-text) (-> Cursor Text Cursor) @@ -5468,7 +5484,7 @@ "This one should fail:" (is 5 (i.+ 2 3)))} (All [a] (-> a a Bool)) - (_lux_proc ["lux" "=="] [left right])) + (_lux_proc ["lux" "is"] [left right])) (macro: #export (^@ tokens) {#;doc (doc "Allows you to simultaneously bind and de-structure a value." @@ -5514,12 +5530,6 @@ _ (fail "Wrong syntax for :!!"))) -(def: #export (error! message) - {#;doc (doc "Causes an error, with the given error message." - (error! "OH NO!"))} - (-> Text Bottom) - (_lux_proc ["jvm" "throw"] [(_lux_proc ["jvm" "new:java.lang.Error:java.lang.String"] [message])])) - (def: #hidden hack_Text/append (-> Text Text Text) Text/append) @@ -5735,3 +5745,7 @@ (type: #export (<.> f g) (All [a] (f (g a)))) + +(def: #export (assume mx) + (All [a] (-> (Maybe a) a)) + (default (undefined) mx)) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 998b42ea8..ce0d5f887 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -17,7 +17,7 @@ [ Nat n.=] [ Int i.=] - [Deg d.=] + [ Deg d.=] [Real r.=] ) @@ -29,9 +29,9 @@ (def: > ) (def: >= ))] - [ Nat Eq n.< n.<= n.> n.>=] - [ Int Eq i.< i.<= i.> i.>=] - [Deg Eq d.< d.<= d.> d.>=] + [ Nat Eq n.< n.<= n.> n.>=] + [ Int Eq i.< i.<= i.> i.>=] + [Deg Eq d.< d.<= d.> d.>=] [Real Eq r.< r.<= r.> r.>=] ) @@ -100,38 +100,34 @@ (def: top ) (def: bottom ))] - [ Nat Ord (_lux_proc ["nat" "max-value"] []) (_lux_proc ["nat" "min-value"] [])] - [ Int Ord (_lux_proc ["jvm" "getstatic:java.lang.Long:MAX_VALUE"] []) (_lux_proc ["jvm" "getstatic:java.lang.Long:MIN_VALUE"] [])] - [Real Ord (_lux_proc ["jvm" "getstatic:java.lang.Double:MAX_VALUE"] []) (_lux_proc ["jvm" "getstatic:java.lang.Double:MIN_VALUE"] [])] - [Deg Ord (_lux_proc ["deg" "max-value"] []) (_lux_proc ["deg" "min-value"] [])]) + [ Nat Ord (_lux_proc [ "nat" "max-value"] []) (_lux_proc [ "nat" "min-value"] [])] + [ Int Ord (_lux_proc [ "int" "max-value"] []) (_lux_proc [ "int" "min-value"] [])] + [Real Ord (_lux_proc ["real" "max-value"] []) (_lux_proc ["real" "min-value"] [])] + [ Deg Ord (_lux_proc [ "deg" "max-value"] []) (_lux_proc [ "deg" "min-value"] [])]) (do-template [ ] [(struct: #export (Monoid ) (def: unit ) (def: (append x y) ( x y)))] - [ Add@Monoid Nat +0 n.+] - [ Mul@Monoid Nat +1 n.*] + [ Add@Monoid Nat +0 n.+] + [ Mul@Monoid Nat +1 n.*] [ Max@Monoid Nat (:: Interval bottom) n.max] [ Min@Monoid Nat (:: Interval top) n.min] - [ Add@Monoid Int 0 i.+] - [ Mul@Monoid Int 1 i.*] + [ Add@Monoid Int 0 i.+] + [ Mul@Monoid Int 1 i.*] [ Max@Monoid Int (:: Interval bottom) i.max] [ Min@Monoid Int (:: Interval top) i.min] - [Add@Monoid Real 0.0 r.+] - [Mul@Monoid Real 1.0 r.*] + [Add@Monoid Real 0.0 r.+] + [Mul@Monoid Real 1.0 r.*] [Max@Monoid Real (:: Interval bottom) r.max] [Min@Monoid Real (:: Interval top) r.min] - [Add@Monoid Deg (:: Interval bottom) d.+] - [Mul@Monoid Deg (:: Interval top) d.*] - [Max@Monoid Deg (:: Interval bottom) d.max] - [Min@Monoid Deg (:: Interval top) d.min] + [ Add@Monoid Deg (:: Interval bottom) d.+] + [ Mul@Monoid Deg (:: Interval top) d.*] + [ Max@Monoid Deg (:: Interval bottom) d.max] + [ Min@Monoid Deg (:: Interval top) d.min] ) -(def: (text.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])) - (do-template [ ] [(struct: #export _ (Codec Text ) (def: (encode x) @@ -145,26 +141,10 @@ #;None (#;Left ))))] - [Nat ["nat" "encode"] ["nat" "decode"] "Couldn't decode Nat"] - [Deg ["deg" "encode"] ["deg" "decode"] "Couldn't decode Deg"] - ) - -(def: clean-number - (-> Text Text) - (text.replace "_" "")) - -(do-template [ ] - [(struct: #export _ (Codec Text ) - (def: (encode x) - (_lux_proc ["jvm" ] [x])) - - (def: (decode input) - (_lux_proc ["jvm" "try"] - [(#;Right (_lux_proc ["jvm" ] [(clean-number input)])) - (lambda [e] (#;Left ))])))] - - [ Int "invokevirtual:java.lang.Object:toString:" "invokestatic:java.lang.Long:parseLong:java.lang.String" "Couldn't parse Int"] - [Real "invokevirtual:java.lang.Object:toString:" "invokestatic:java.lang.Double:parseDouble:java.lang.String" "Couldn't parse Real"] + [ Nat [ "nat" "encode"] [ "nat" "decode"] "Couldn't decode Nat"] + [ Int [ "int" "encode"] [ "int" "decode"] "Couldn't decode Int"] + [ Deg [ "deg" "encode"] [ "deg" "decode"] "Couldn't decode Deg"] + [Real ["real" "encode"] ["real" "decode"] "Couldn't decode Real"] ) (struct: #export _ (Hash Nat) @@ -178,13 +158,24 @@ (struct: #export _ (Hash Real) (def: eq Eq) - (def: hash - (|>. (:: Codec encode) - [] - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:hashCode:"]) - [] - (_lux_proc ["jvm" "i2l"]) - int-to-nat))) + (def: (hash value) + (_lux_proc ["real" "hash"] [value]))) + +(do-template [ ] + [(def: #export + {#;doc } + Real + (_lux_proc ["real" ] []))] + + [not-a-number "not-a-number" "Not-a-number."] + [positive-infinity "positive-infinity" "Positive infinity."] + [negative-infinity "negative-infinity" "Negative infinity."] + ) + +(def: #export (not-a-number? number) + {#;doc "Tests whether a real is actually not-a-number."} + (-> Real Bool) + (not (r.= number number))) ## [Values & Syntax] (do-template [ ] @@ -221,19 +212,3 @@ (doc "Given syntax for a hexadecimal number, generates a Nat." (hex "deadBEEF"))] ) - -(do-template [ ] - [(def: #export - {#;doc } - Real - (_lux_proc ["jvm" ] []))] - - [nan "getstatic:java.lang.Double:NaN" "Not-a-number."] - [+inf "getstatic:java.lang.Double:POSITIVE_INFINITY" "Positive infinity."] - [-inf "getstatic:java.lang.Double:NEGATIVE_INFINITY" "Negative infinity."] - ) - -(def: #export (nan? number) - {#;doc "Tests whether a real is actually not-a-number."} - (-> Real Bool) - (not (r.= number number))) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index bec6d7d2b..9375d6876 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -33,7 +33,7 @@ [trim "invokevirtual:java.lang.String:trim:"] ) -(def: #export (sub from to x) +(def: #export (clip from to x) (-> Nat Nat Text (Maybe Text)) (if (and (n.< to from) (n.<= (size x) to)) @@ -43,9 +43,9 @@ (_lux_proc ["jvm" "l2i"] [(nat-to-int to)])])) #;None)) -(def: #export (sub' from x) +(def: #export (clip' from x) (-> Nat Text (Maybe Text)) - (sub from (size x) x)) + (clip from (size x) x)) (def: #export (replace pattern value template) (-> Text Text Text Text) @@ -158,7 +158,7 @@ (def: (decode input) (if (and (starts-with? "\"" input) (ends-with? "\"" input)) - (case (sub +1 (n.dec (size input)) input) + (case (clip +1 (n.dec (size input)) input) (#;Some input') (|> input' (replace "\\\\" "\\") diff --git a/stdlib/source/lux/math/complex.lux b/stdlib/source/lux/math/complex.lux index eae4fbe55..87b1a7d18 100644 --- a/stdlib/source/lux/math/complex.lux +++ b/stdlib/source/lux/math/complex.lux @@ -38,9 +38,9 @@ (def: #export zero Complex (complex 0.0 0.0)) -(def: #export (nan? complex) - (or (number;nan? (get@ #real complex)) - (number;nan? (get@ #imaginary complex)))) +(def: #export (not-a-number? complex) + (or (number;not-a-number? (get@ #real complex)) + (number;not-a-number? (get@ #imaginary complex)))) (def: #export (c.= param input) (-> Complex Complex Bool) @@ -317,7 +317,7 @@ (def: (decode input) (case (do Monad - [input' (text;sub +1 (n.- +1 (text;size input)) input)] + [input' (text;clip +1 (n.- +1 (text;size input)) input)] (text;split-with "," input')) #;None (#;Left (Text/append "Wrong syntax for complex numbers: " input)) 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.2.3 From 277747aee1b0b19e88a0e685299f278201737011 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 17 Feb 2017 18:24:45 -0400 Subject: - Added more common procedures. - Fixed some bugs in the type-checking of some common procedures. - Removed the "_name" field for generated classes. - Now compiling loops in JS. - Did some refactoring to the caching machinery. - Implemented binary, octal and hexadecimal encoding purely in Lux. --- stdlib/source/lux/data/number.lux | 42 +++++++++++++++++++++++++++++++-------- 1 file changed, 34 insertions(+), 8 deletions(-) (limited to 'stdlib') diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index ce0d5f887..cad152f2b 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -178,15 +178,38 @@ (not (r.= number number))) ## [Values & Syntax] -(do-template [ ] +(do-template [ ] [(struct: #export (Codec Text Nat) (def: (encode value) - (_lux_proc ["jvm" ] [(nat-to-int value)])) + (loop [input value + output ""] + (let [digit (assume (_lux_proc ["text" "char"] [ (n.% input)])) + output' (_lux_proc ["text" "append"] [(_lux_proc ["char" "to-text"] [digit]) + output]) + input' (n./ input)] + (if (n.= +0 input') + output' + (recur input' output'))))) (def: (decode repr) - (_lux_proc ["jvm" "try"] - [(#;Right (int-to-nat (_lux_proc ["jvm" "invokestatic:java.lang.Long:parseUnsignedLong:java.lang.String,int"] [repr (_lux_proc ["jvm" "l2i"] [])]))) - (lambda [ex] (#;Left ))]))) + (let [input-size (_lux_proc ["text" "size"] [repr])] + (if (n.= +0 input-size) + (#;Left "Empty input.") + (let [input (_lux_proc ["text" "upper-case"] [repr])] + (loop [idx +0 + output +0] + (if (n.< input-size idx) + (let [digit (assume (_lux_proc ["text" "char"] [input idx]))] + (case (_lux_proc ["text" "index"] + [input + (_lux_proc ["char" "to-text"] [digit])]) + #;None + (#;Left ) + + (#;Some index) + (recur (n.inc idx) + (|> output (n.* ) (n.* index))))) + (#;Right output)))))))) (macro: #export ( tokens state) {#;doc } @@ -202,13 +225,16 @@ _ (#;Left )))] - [Binary@Codec "invokestatic:java.lang.Long:toBinaryString:long" 2 bin "Invalid binary syntax." + [Binary@Codec +2 bin "Invalid binary syntax." + "01" (doc "Given syntax for a binary number, generates a Nat." (bin "11001001"))] - [Octal@Codec "invokestatic:java.lang.Long:toOctalString:long" 8 oct "Invalid octal syntax." + [Octal@Codec +8 oct "Invalid octal syntax." + "01234567" (doc "Given syntax for an octal number, generates a Nat." (oct "615243"))] - [Hex@Codec "invokestatic:java.lang.Long:toHexString:long" 16 hex "Invalid hexadecimal syntax." + [Hex@Codec +16 hex "Invalid hexadecimal syntax." + "0123456789ABCDEF" (doc "Given syntax for a hexadecimal number, generates a Nat." (hex "deadBEEF"))] ) -- cgit v1.2.3 From 71d7ff61aa914e153965a4ef6a7ae72b4fb54581 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 17 Feb 2017 22:40:06 -0400 Subject: - Added support for the new common procedures to the JVM backend. - Fixed some bugs. --- stdlib/source/lux/data/number.lux | 4 ++-- stdlib/source/lux/data/text.lux | 30 ++++++++++++++---------------- 2 files changed, 16 insertions(+), 18 deletions(-) (limited to 'stdlib') diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index cad152f2b..0c52653af 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -201,14 +201,14 @@ (if (n.< input-size idx) (let [digit (assume (_lux_proc ["text" "char"] [input idx]))] (case (_lux_proc ["text" "index"] - [input + [ (_lux_proc ["char" "to-text"] [digit])]) #;None (#;Left ) (#;Some index) (recur (n.inc idx) - (|> output (n.* ) (n.* index))))) + (|> output (n.* ) (n.+ index))))) (#;Right output)))))))) (macro: #export ( tokens state) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index 9375d6876..bc350cc3a 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -12,40 +12,38 @@ ## [Functions] (def: #export (size x) (-> Text Nat) - (int-to-nat (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])]))) + [(_lux_proc ["text" "size"] [x])]) -(def: #export (nth idx x) +(def: #export (nth idx input) (-> Nat Text (Maybe Char)) - (if (n.< (size x) idx) - (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:charAt:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int idx)])])) - #;None)) + (_lux_proc ["text" "char"] [input idx])) (def: #export (contains? sub text) (-> Text Text Bool) (_lux_proc ["jvm" "invokevirtual:java.lang.String:contains:java.lang.CharSequence"] [text sub])) (do-template [ ] - [(def: #export ( x) + [(def: #export ( input) (-> Text Text) - (_lux_proc ["jvm" ] [x]))] - [lower-case "invokevirtual:java.lang.String:toLowerCase:"] - [upper-case "invokevirtual:java.lang.String:toUpperCase:"] - [trim "invokevirtual:java.lang.String:trim:"] + (_lux_proc ["text" ] [input]))] + [lower-case "lower-case"] + [upper-case "upper-case"] + [trim "trim"] ) -(def: #export (clip from to x) +(def: #export (clip from to input) (-> Nat Nat Text (Maybe Text)) (if (and (n.< to from) - (n.<= (size x) to)) + (n.<= (size input) to)) (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] - [x + [input (_lux_proc ["jvm" "l2i"] [(nat-to-int from)]) (_lux_proc ["jvm" "l2i"] [(nat-to-int to)])])) #;None)) -(def: #export (clip' from x) +(def: #export (clip' from input) (-> Nat Text (Maybe Text)) - (clip from (size x) x)) + (clip from (size input) input)) (def: #export (replace pattern value template) (-> Text Text Text Text) @@ -120,7 +118,7 @@ ## [Structures] (struct: #export _ (Eq Text) (def: (= test subject) - (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [subject test]))) + (_lux_proc ["text" "="] [subject test]))) (struct: #export _ (ord;Ord Text) (def: eq Eq) -- cgit v1.2.3 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. --- 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 ++-- 6 files changed, 106 insertions(+), 119 deletions(-) (limited to 'stdlib') 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.2.3 From 5fb0985b7a33ccfc6c53d65ce00a643f9d8d20ee Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 23 Feb 2017 18:12:42 -0400 Subject: - Re-designed atomic operations as common procedures. - Implemented atomic operations for the JVM. - Basic Lux types no longer rely on JVM classes. --- stdlib/source/lux.lux | 10 +++++----- stdlib/source/lux/concurrency/atom.lux | 20 +++++++------------- stdlib/source/lux/concurrency/stm.lux | 1 - 3 files changed, 12 insertions(+), 19 deletions(-) (limited to 'stdlib') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 01064b829..7ae8c2847 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -1,7 +1,7 @@ ## Basic types (_lux_def Bool (+12 ["lux" "Bool"] - (+0 "java.lang.Boolean" (+0))) + (+0 "#Bool" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill boolean values.")] @@ -19,7 +19,7 @@ (_lux_def Int (+12 ["lux" "Int"] - (+0 "java.lang.Long" (+0))) + (+0 "#Int" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill integer numbers.")] @@ -27,7 +27,7 @@ (_lux_def Real (+12 ["lux" "Real"] - (+0 "java.lang.Double" (+0))) + (+0 "#Real" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill floating-point numbers.")] @@ -45,7 +45,7 @@ (_lux_def Char (+12 ["lux" "Char"] - (+0 "java.lang.Character" (+0))) + (+0 "#Char" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill character values.")] @@ -53,7 +53,7 @@ (_lux_def Text (+12 ["lux" "Text"] - (+0 "java.lang.String" (+0))) + (+0 "#Text" (+0))) (+1 [["lux" "type?"] (+0 true)] (+1 [["lux" "export?"] (+0 true)] (+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill string values.")] diff --git a/stdlib/source/lux/concurrency/atom.lux b/stdlib/source/lux/concurrency/atom.lux index 09dd642ed..f2ec8b46c 100644 --- a/stdlib/source/lux/concurrency/atom.lux +++ b/stdlib/source/lux/concurrency/atom.lux @@ -1,31 +1,25 @@ (;module: lux - (lux [io #- run] - host)) - -(jvm-import (java.util.concurrent.atomic.AtomicReference V) - (new [V]) - (compareAndSet [V V] boolean) - (get [] V)) + (lux [io #- run])) (type: #export (Atom a) {#;doc "Atomic references that are safe to mutate concurrently."} - (AtomicReference a)) + (#;HostT "#Atom" (#;Cons a #;Nil))) (def: #export (atom value) (All [a] (-> a (Atom a))) - (AtomicReference.new [value])) + (_lux_proc ["atom" "new"] [value])) (def: #export (get atom) (All [a] (-> (Atom a) (IO a))) - (io (AtomicReference.get [] atom))) + (io (_lux_proc ["atom" "get"] [atom]))) (def: #export (compare-and-swap current new atom) {#;doc "Only mutates an atom if you can present it's current value. That guarantees that atom wasn't updated since you last read from it."} (All [a] (-> a a (Atom a) (IO Bool))) - (io (AtomicReference.compareAndSet [current new] atom))) + (io (_lux_proc ["atom" "compare-and-swap"] [atom current new]))) (def: #export (update f atom) {#;doc "Updates an atom by applying a function to its current value. @@ -34,8 +28,8 @@ The retries will be done with the new values of the atom, as they show up."} (All [a] (-> (-> a a) (Atom a) (IO Unit))) - (io (let [old (AtomicReference.get [] atom)] - (if (AtomicReference.compareAndSet [old (f old)] atom) + (io (let [old (_lux_proc ["atom" "get"] [atom])] + (if (_lux_proc ["atom" "compare-and-swap"] [atom old (f old)]) [] (io;run (update f atom)))))) diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux index 36eb6854e..c1c3153dd 100644 --- a/stdlib/source/lux/concurrency/stm.lux +++ b/stdlib/source/lux/concurrency/stm.lux @@ -12,7 +12,6 @@ maybe [number "Nat/" Codec] text/format) - host [compiler] (macro [ast] ["s" syntax #+ syntax: Syntax]) -- cgit v1.2.3 From 8ff8934813562f28f79cc08014947eb282256e6a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 23 Feb 2017 19:46:22 -0400 Subject: - Re-designed (and implemented) the primitives for running processes/threads as Lux procedures. --- stdlib/source/lux/concurrency/promise.lux | 47 +++---------------------------- 1 file changed, 4 insertions(+), 43 deletions(-) (limited to 'stdlib') diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux index 3c10e785d..ef7efd923 100644 --- a/stdlib/source/lux/concurrency/promise.lux +++ b/stdlib/source/lux/concurrency/promise.lux @@ -12,47 +12,11 @@ [compiler] (macro ["s" syntax #+ syntax: Syntax]) (concurrency [atom #+ Atom atom]) - host )) -(jvm-import java.lang.Runtime - (#static getRuntime [] Runtime) - (availableProcessors [] int)) - -(jvm-import java.lang.Runnable) - -(jvm-import java.lang.Thread - (new [Runnable]) - (start [] void)) - -(jvm-import java.util.concurrent.Executor - (execute [Runnable] void)) - -(jvm-import java.util.concurrent.TimeUnit - (#enum MILLISECONDS)) - -(jvm-import (java.util.concurrent.ScheduledFuture a)) - -(jvm-import java.util.concurrent.ScheduledThreadPoolExecutor - (new [int]) - (schedule [Runnable long TimeUnit] (ScheduledFuture Object))) - (def: #export concurrency-level Nat - (|> (Runtime.getRuntime []) - (Runtime.availableProcessors []) - int-to-nat)) - -(def: executor - ScheduledThreadPoolExecutor - (ScheduledThreadPoolExecutor.new [(nat-to-int concurrency-level)])) - -(syntax: (runnable expr) - (wrap (list (`' (object [java.lang.Runnable] - [] - (java.lang.Runnable (run) void - (exec (~ expr) - []))))))) + (_lux_proc ["process" "concurrency-level"] [])) (type: (Promise-State a) {#value (Maybe a) @@ -218,18 +182,15 @@ {#;doc "Runs an I/O computation on its own process and returns an Promise that will eventually host its result."} (All [a] (-> (IO a) (Promise a))) (let [!out (promise ($ +0))] - (exec (Thread.start [] (Thread.new [(runnable (io;run (resolve (io;run computation) - !out)))])) + (exec (_lux_proc ["process" "future"] [(io (io;run (resolve (io;run computation) + !out)))]) !out))) (def: #export (wait time) {#;doc "Returns a Promise that will be resolved after the specified amount of milliseconds."} (-> Nat (Promise Unit)) (let [!out (promise Unit)] - (exec (ScheduledThreadPoolExecutor.schedule [(runnable (io;run (resolve [] !out))) - (nat-to-int time) - TimeUnit.MILLISECONDS] - executor) + (exec (_lux_proc ["process" "schedule"] [time (resolve [] !out)]) !out))) (def: #export (time-out time promise) -- cgit v1.2.3 From cbeafbafc0ab02d8c8335ccc106a90545d562985 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 25 Feb 2017 19:57:30 -0400 Subject: - Exiting the program and getting the current time (in milliseconds) is now done through procedures. --- stdlib/source/lux/test.lux | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) (limited to 'stdlib') diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index 82fcabed9..bab513cc4 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -17,12 +17,13 @@ [host #- try])) ## [Host] -(jvm-import java.lang.System - (#static exit [int] #io void) - (#static currentTimeMillis [] #io long)) +(def: now + (IO Int) + (io (_lux_proc ["io" "current-time"] []))) (do-template [ ] - [(def: #hidden (IO Unit) (System.exit ))] + [(def: #hidden (IO Bottom) + (io (_lux_proc ["io" "exit"] [])))] [exit 0] [die 1] @@ -51,9 +52,9 @@ [#let [test-runs (List/map (: (-> [Text (IO Test) Text] (Promise Nat)) (lambda [[module test description]] (do @ - [#let [pre (io;run (System.currentTimeMillis []))] + [#let [pre (io;run now)] outcome (io;run test) - #let [post (io;run (System.currentTimeMillis [])) + #let [post (io;run now) description+ (:: text;Codec encode description)]] (case outcome (#;Left error) @@ -107,7 +108,7 @@ (def: #hidden (repeat ?seed times random-test) (-> (Maybe Nat) Nat (R;Random Test) Test) - (repeat' (default (int-to-nat (io;run (System.currentTimeMillis []))) + (repeat' (default (int-to-nat (io;run now)) ?seed) (case ?seed #;None times -- cgit v1.2.3 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. --- stdlib/source/lux/math.lux | 3 --- stdlib/test/test/lux/math.lux | 3 --- 2 files changed, 6 deletions(-) (limited to 'stdlib') 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.2.3 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. --- stdlib/source/lux/test.lux | 5 ++--- stdlib/test/test/lux/data/char.lux | 3 +-- 2 files changed, 3 insertions(+), 5 deletions(-) (limited to 'stdlib') 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.2.3 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. --- 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 --- 6 files changed, 2405 insertions(+), 2290 deletions(-) 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') 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.2.3