From af7f85c4eb724f2888ecce9c8b52d6d3bb1cd807 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 27 Apr 2019 23:41:47 -0400 Subject: Moved JVM type machinery to stdlib. --- stdlib/source/lux/target/jvm/type.lux | 205 +++++++++++++++++++++ .../source/lux/tool/compiler/meta/io/context.lux | 24 +-- stdlib/source/lux/world/console.lux | 118 ++++++------ stdlib/source/program/compositor.lux | 2 - 4 files changed, 277 insertions(+), 72 deletions(-) create mode 100644 stdlib/source/lux/target/jvm/type.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux new file mode 100644 index 000000000..23925e468 --- /dev/null +++ b/stdlib/source/lux/target/jvm/type.lux @@ -0,0 +1,205 @@ +(.module: + [lux (#- Type int char) + [data + ["." maybe ("#@." functor)] + ["." text + format] + [collection + ["." list ("#@." functor)]]]]) + +(def: array-prefix "[") +(def: binary-void-name "V") +(def: binary-boolean-name "Z") +(def: binary-byte-name "B") +(def: binary-short-name "S") +(def: binary-int-name "I") +(def: binary-long-name "J") +(def: binary-float-name "F") +(def: binary-double-name "D") +(def: binary-char-name "C") +(def: binary-object-prefix "L") +(def: binary-object-suffix ";") +(def: object-class "java.lang.Object") + +(type: #export Bound + #Upper + #Lower) + +(type: #export Primitive + #Boolean + #Byte + #Short + #Int + #Long + #Float + #Double + #Char) + +(type: #export #rec Generic + (#Var Text) + (#Wildcard (Maybe [Bound Generic])) + (#Class Text (List Generic))) + +(type: #export Class + [Text (List Generic)]) + +(type: #export Parameter + [Text Class (List Class)]) + +(type: #export #rec Type + (#Primitive Primitive) + (#Generic Generic) + (#Array Type)) + +(type: #export Method + {#args (List Type) + #return (Maybe Type) + #exceptions (List Generic)}) + +(template [ ] + [(def: #export Type (#Primitive ))] + + [boolean #Boolean] + [byte #Byte] + [short #Short] + [int #Int] + [long #Long] + [float #Float] + [double #Double] + [char #Char] + ) + +(template: #export (class name params) + (#..Generic (#..Class name params))) + +(template: #export (var name) + (#..Generic (#..Var name))) + +(template: #export (wildcard bound) + (#..Generic (#..Wildcard bound))) + +(def: #export (array depth elemT) + (-> Nat Type Type) + (case depth + 0 elemT + _ (#Array (array (dec depth) elemT)))) + +(def: #export binary-name + (-> Text Text) + (text.replace-all "." "/")) + +(def: #export (descriptor type) + (-> Type Text) + (case type + (#Primitive prim) + (case prim + #Boolean ..binary-boolean-name + #Byte ..binary-byte-name + #Short ..binary-short-name + #Int ..binary-int-name + #Long ..binary-long-name + #Float ..binary-float-name + #Double ..binary-double-name + #Char ..binary-char-name) + + (#Array sub) + (format ..array-prefix (descriptor sub)) + + (#Generic generic) + (case generic + (#Class class params) + (format ..binary-object-prefix (binary-name class) ..binary-object-suffix) + + (^or (#Var name) (#Wildcard ?bound)) + (descriptor (#Generic (#Class ..object-class (list))))) + )) + +(def: #export (class-name type) + (-> Type (Maybe Text)) + (case type + (#Primitive prim) + #.None + + (#Array sub) + (#.Some (descriptor type)) + + (#Generic generic) + (case generic + (#Class class params) + (#.Some class) + + (^or (#Var name) (#Wildcard ?bound)) + (#.Some ..object-class)) + )) + +(def: #export (signature type) + (-> Type Text) + (case type + (#Primitive prim) + (case prim + #Boolean ..binary-boolean-name + #Byte ..binary-byte-name + #Short ..binary-short-name + #Int ..binary-int-name + #Long ..binary-long-name + #Float ..binary-float-name + #Double ..binary-double-name + #Char ..binary-char-name) + + (#Array sub) + (format ..array-prefix (signature sub)) + + (#Generic generic) + (case generic + (#Class class params) + (let [=params (if (list.empty? params) + "" + (format "<" + (|> params + (list@map (|>> #Generic signature)) + (text.join-with "")) + ">"))] + (format ..binary-object-prefix (binary-name class) =params ..binary-object-suffix)) + + (#Var name) + (format "T" name ..binary-object-suffix) + + (#Wildcard #.None) + "*" + + (^template [ ] + (#Wildcard (#.Some [ bound])) + (format (signature (#Generic bound)))) + ([#Upper "+"] + [#Lower "-"])) + )) + +(def: #export (method args return exceptions) + (-> (List Type) (Maybe Type) (List Generic) Method) + {#args args #return return #exceptions exceptions}) + +(def: method-args + (text.enclose ["(" ")"])) + +(def: #export (method-descriptor method) + (-> Method Text) + (format (|> (get@ #args method) (list@map descriptor) (text.join-with "") ..method-args) + (case (get@ #return method) + #.None + ..binary-void-name + + (#.Some return) + (descriptor return)))) + +(def: #export (method-signature method) + (-> Method Text) + (format (|> (get@ #args method) (list@map signature) (text.join-with "") ..method-args) + (case (get@ #return method) + #.None + ..binary-void-name + + (#.Some return) + (signature return)) + (|> (get@ #exceptions method) + (list@map (|>> #Generic signature (format "^"))) + (text.join-with "")))) diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux index b60616f03..bd1efd73b 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/context.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/context.lux @@ -1,5 +1,6 @@ (.module: [lux (#- Module Code) + ["@" target] [abstract [monad (#+ Monad do)]] [control @@ -19,8 +20,7 @@ ["#/" // #_ [archive [descriptor (#+ Module)]] - ["#/" // (#+ Input) - ["#." host]]]]) + ["#/" // (#+ Input)]]]) (template [] [(exception: #export ( {module Module}) @@ -38,16 +38,16 @@ (def: partial-host-extension Extension - (`` (for {(~~ (static ////host.common-lisp)) ".cl" - (~~ (static ////host.js)) ".js" - (~~ (static ////host.old)) ".jvm" - (~~ (static ////host.jvm)) ".jvm" - (~~ (static ////host.lua)) ".lua" - (~~ (static ////host.php)) ".php" - (~~ (static ////host.python)) ".py" - (~~ (static ////host.r)) ".r" - (~~ (static ////host.ruby)) ".rb" - (~~ (static ////host.scheme)) ".scm"}))) + (`` (for {(~~ (static @.common-lisp)) ".cl" + (~~ (static @.js)) ".js" + (~~ (static @.old)) ".jvm" + (~~ (static @.jvm)) ".jvm" + (~~ (static @.lua)) ".lua" + (~~ (static @.php)) ".php" + (~~ (static @.python)) ".py" + (~~ (static @.r)) ".r" + (~~ (static @.ruby)) ".rb" + (~~ (static @.scheme)) ".scm"}))) (def: full-host-extension Extension diff --git a/stdlib/source/lux/world/console.lux b/stdlib/source/lux/world/console.lux index effcff8a3..cc5258724 100644 --- a/stdlib/source/lux/world/console.lux +++ b/stdlib/source/lux/world/console.lux @@ -1,5 +1,7 @@ (.module: [lux #* + [host (#+ import:)] + ["@" target] [abstract [monad (#+ do)]] [control @@ -12,11 +14,7 @@ [data ["." error (#+ Error)] ["." text - format]] - [host (#+ import:)] - [tool - [compiler - ["." host]]]]) + format]]]) (template [] [(exception: #export () @@ -57,59 +55,63 @@ [can-write ..can-write] [can-close ..can-close]))))) -(`` (for {(~~ (static host.old)) - (as-is (import: java/lang/String) - - (import: #long java/io/Console - (readLine [] #io #try String)) - - (import: java/io/InputStream - (read [] #io #try int)) - - (import: java/io/PrintStream - (print [String] #io #try void)) - - (import: java/lang/System - (#static console [] #io #? java/io/Console) - (#static in java/io/InputStream) - (#static out java/io/PrintStream)) - - (def: #export system - (IO (Error (Console IO))) - (do io.monad - [?jvm-console (System::console)] - (case ?jvm-console - #.None - (wrap (ex.throw cannot-open [])) - - (#.Some jvm-console) - (let [jvm-input (System::in) - jvm-output (System::out)] - (<| wrap - ex.return - (: (Console IO)) ## TODO: Remove ASAP - (structure - (def: can-read - (..can-read - (function (_ _) - (|> jvm-input - InputStream::read - (:: (error.with io.monad) map .nat))))) - - (def: can-read-line - (..can-read - (function (_ _) - (java/io/Console::readLine jvm-console)))) - - (def: can-write - (..can-write - (function (_ message) - (PrintStream::print message jvm-output)))) - - (def: can-close - (..can-close - (|>> (ex.throw cannot-close) wrap)))))))))) - })) +(with-expansions [ (as-is (import: java/lang/String) + + (import: #long java/io/Console + (readLine [] #io #try String)) + + (import: java/io/InputStream + (read [] #io #try int)) + + (import: java/io/PrintStream + (print [String] #io #try void)) + + (import: java/lang/System + (#static console [] #io #? java/io/Console) + (#static in java/io/InputStream) + (#static out java/io/PrintStream)) + + (def: #export system + (IO (Error (Console IO))) + (do io.monad + [?jvm-console (System::console)] + (case ?jvm-console + #.None + (wrap (ex.throw cannot-open [])) + + (#.Some jvm-console) + (let [jvm-input (System::in) + jvm-output (System::out)] + (<| wrap + ex.return + (: (Console IO)) ## TODO: Remove ASAP + (structure + (def: can-read + (..can-read + (function (_ _) + (|> jvm-input + InputStream::read + (:: (error.with io.monad) map .nat))))) + + (def: can-read-line + (..can-read + (function (_ _) + (java/io/Console::readLine jvm-console)))) + + (def: can-write + (..can-write + (function (_ message) + (PrintStream::print message jvm-output)))) + + (def: can-close + (..can-close + (|>> (ex.throw cannot-close) wrap))))))))))] + (`` (for {(~~ (static @.old)) + (as-is ) + + (~~ (static @.jvm)) + (as-is ) + }))) (def: #export (write-line message console) (All [!] (-> Text (Console !) (! Any))) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index 5dd2fd1ba..c39544019 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -20,8 +20,6 @@ ["." list ("#@." functor fold)]]] [time ["." instant (#+ Instant)]] - [host - ["_" js]] [world ["." file (#+ File)] ["." console]] -- cgit v1.2.3