diff options
Diffstat (limited to 'stdlib/source')
22 files changed, 507 insertions, 268 deletions
diff --git a/stdlib/source/lux/control/concurrency/atom.lux b/stdlib/source/lux/control/concurrency/atom.lux index d16b485f7..d15ccfc28 100644 --- a/stdlib/source/lux/control/concurrency/atom.lux +++ b/stdlib/source/lux/control/concurrency/atom.lux @@ -1,27 +1,30 @@ (.module: [lux #* - [host (#+ import:)] + ["." host] ["@" target] [abstract [monad (#+ do)]] [control ["." function] ["." io (#- run)]] + [data + [collection + ["." array]]] [type abstract]]) (`` (for {(~~ (static @.old)) - (import: #long (java/util/concurrent/atomic/AtomicReference a) + (host.import: #long (java/util/concurrent/atomic/AtomicReference a) (new [a]) (get [] a) (compareAndSet [a a] boolean)) (~~ (static @.jvm)) - (import: #long (java/util/concurrent/atomic/AtomicReference a) + (host.import: #long (java/util/concurrent/atomic/AtomicReference a) (new [a]) (get [] a) - (compareAndSet [a a] boolean)) - })) + (compareAndSet [a a] boolean))} + (as-is))) (`` (abstract: #export (Atom a) {#.doc "Atomic references that are safe to mutate concurrently."} @@ -31,6 +34,9 @@ (~~ (static @.jvm)) (java/util/concurrent/atomic/AtomicReference a) + + (~~ (static @.js)) + (array.Array a) }) (def: #export (atom value) @@ -40,6 +46,9 @@ (~~ (static @.jvm)) (java/util/concurrent/atomic/AtomicReference::new value) + + (~~ (static @.js)) + ("js array write" 0 value ("js array new" 1)) }))) (def: #export (read atom) @@ -49,6 +58,9 @@ (~~ (static @.jvm)) (java/util/concurrent/atomic/AtomicReference::get (:representation atom)) + + (~~ (static @.js)) + ("js array read" 0 (:representation atom)) }))) (def: #export (compare-and-swap current new atom) @@ -60,7 +72,13 @@ (~~ (static @.jvm)) (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom)) - }))) + + (~~ (static @.js)) + (let [old ("js array read" 0 (:representation atom))] + (if (is? old current) + (exec ("js array write" 0 new (:representation atom)) + true) + false))}))) )) (def: #export (update f atom) diff --git a/stdlib/source/lux/control/concurrency/process.lux b/stdlib/source/lux/control/concurrency/process.lux index fc5ad2050..7cb569ee9 100644 --- a/stdlib/source/lux/control/concurrency/process.lux +++ b/stdlib/source/lux/control/concurrency/process.lux @@ -1,7 +1,7 @@ (.module: [lux #* ["@" target] - ["." host (#+ import: object)] + ["." host] [abstract ["." monad (#+ do)]] [control @@ -14,44 +14,44 @@ ["." atom (#+ Atom)]]) (`` (for {(~~ (static @.old)) - (as-is (import: #long java/lang/Object) + (as-is (host.import: #long java/lang/Object) - (import: #long java/lang/Runtime + (host.import: #long java/lang/Runtime (#static getRuntime [] java/lang/Runtime) (availableProcessors [] int)) - (import: #long java/lang/Runnable) + (host.import: #long java/lang/Runnable) - (import: #long java/util/concurrent/TimeUnit + (host.import: #long java/util/concurrent/TimeUnit (#enum MILLISECONDS)) - (import: #long java/util/concurrent/Executor + (host.import: #long java/util/concurrent/Executor (execute [java/lang/Runnable] #io void)) - (import: #long (java/util/concurrent/ScheduledFuture a)) + (host.import: #long (java/util/concurrent/ScheduledFuture a)) - (import: #long java/util/concurrent/ScheduledThreadPoolExecutor + (host.import: #long java/util/concurrent/ScheduledThreadPoolExecutor (new [int]) (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object)))) (~~ (static @.jvm)) - (as-is (import: #long java/lang/Object) + (as-is (host.import: #long java/lang/Object) - (import: #long java/lang/Runtime + (host.import: #long java/lang/Runtime (#static getRuntime [] java/lang/Runtime) (availableProcessors [] int)) - (import: #long java/lang/Runnable) + (host.import: #long java/lang/Runnable) - (import: #long java/util/concurrent/TimeUnit + (host.import: #long java/util/concurrent/TimeUnit (#enum MILLISECONDS)) - (import: #long java/util/concurrent/Executor + (host.import: #long java/util/concurrent/Executor (execute [java/lang/Runnable] #io void)) - (import: #long (java/util/concurrent/ScheduledFuture a)) + (host.import: #long (java/util/concurrent/ScheduledFuture a)) - (import: #long java/util/concurrent/ScheduledThreadPoolExecutor + (host.import: #long java/util/concurrent/ScheduledThreadPoolExecutor (new [int]) (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object))))} @@ -91,7 +91,7 @@ (def: #export (schedule milli-seconds action) (-> Nat (IO Any) (IO Any)) (`` (for {(~~ (static @.old)) - (let [runnable (object [] [java/lang/Runnable] + (let [runnable (host.object [] [java/lang/Runnable] [] (java/lang/Runnable [] (run self) void (io.run action)))] @@ -101,7 +101,7 @@ runner))) (~~ (static @.jvm)) - (let [runnable (object [] [java/lang/Runnable] + (let [runnable (host.object [] [java/lang/Runnable] [] (java/lang/Runnable [] (run self) void (io.run action)))] @@ -111,10 +111,12 @@ runner)))} ## Default - (atom.update (|>> (#.Cons {#creation ("lux io current-time") - #delay milli-seconds - #action action})) - runner)))) + (do io.monad + [_ (atom.update (|>> (#.Cons {#creation (.nat ("lux io current-time")) + #delay milli-seconds + #action action})) + runner)] + (wrap []))))) (`` (for {(~~ (static @.old)) (as-is) @@ -137,15 +139,17 @@ _ (do @ - [#let [now ("lux io current-time") + [#let [now (.nat ("lux io current-time")) [ready pending] (list.partition (function (_ process) (|> (get@ #creation process) (n/+ (get@ #delay process)) (n/<= now))) processes)] - swapped? (atom.compare-and-swap! processes pending runner)] + swapped? (atom.compare-and-swap processes pending runner)] (if swapped? - (monad.seq @ ready) + (do @ + [_ (monad.map @ (get@ #action) ready)] + (wrap [])) (error! (ex.construct cannot-continue-running-processes [])))) )))) ))) diff --git a/stdlib/source/lux/control/thread.lux b/stdlib/source/lux/control/thread.lux index b27e56395..7dfa4c490 100644 --- a/stdlib/source/lux/control/thread.lux +++ b/stdlib/source/lux/control/thread.lux @@ -40,7 +40,10 @@ (:coerce (primitive "java.lang.Long")) "jvm object cast" "jvm conversion long-to-int") - (:representation box))})))) + (:representation box)) + + (~~ (static @.js)) + ("js array read" 0 (:representation box))})))) (def: #export (write value box) (All [a] (-> a (All [!] (-> (Box ! a) (Thread ! Any))))) diff --git a/stdlib/source/lux/control/writer.lux b/stdlib/source/lux/control/writer.lux index 866fe0b18..1b82bf0c7 100644 --- a/stdlib/source/lux/control/writer.lux +++ b/stdlib/source/lux/control/writer.lux @@ -62,10 +62,9 @@ (do monad [[l1 Mla] (`` (for {(~~ (static @.old)) (: (($ 1) (Writer ($ 0) (($ 1) (Writer ($ 0) ($ 2))))) - MlMla) - - (~~ (static @.jvm)) - MlMla})) + MlMla)} + ## On new compiler + MlMla)) [l2 a] Mla] (wrap [(:: monoid compose l1 l2) a])))) diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux index cac39d65f..b109fc2fb 100644 --- a/stdlib/source/lux/data/collection/array.lux +++ b/stdlib/source/lux/data/collection/array.lux @@ -40,7 +40,10 @@ !int "jvm array new object" (: <array-type>) - :assume)}))) + :assume) + + (~~ (static @.js)) + ("js array new" size)}))) (def: #export (size array) (All [a] (-> (Array a) Nat)) @@ -54,7 +57,10 @@ "jvm conversion int-to-long" "jvm object cast" (: <index-type>) - (:coerce Nat))}))) + (:coerce Nat)) + + (~~ (static @.js)) + ("js array length" array)}))) (def: #export (read index array) (All [a] @@ -72,7 +78,13 @@ ("jvm array read object" (!int index)))] (if ("jvm object null?" value) #.None - (#.Some (:assume value))))})) + (#.Some (:assume value)))) + + (~~ (static @.js)) + (let [output ("js array read" index array)] + (if ("js undefined?" output) + #.None + (#.Some output)))})) #.None)) (def: #export (write index value array) @@ -85,7 +97,10 @@ (|> array (:coerce <array-type>) ("jvm array write object" (!int index) (:coerce <elem-type> value)) - :assume)}))) + :assume) + + (~~ (static @.js)) + ("js array write" index value array)}))) (def: #export (delete index array) (All [a] @@ -95,7 +110,10 @@ (write index (:assume ("jvm object null")) array) (~~ (static @.jvm)) - (write index (:assume (: <elem-type> ("jvm object null"))) array)})) + (write index (:assume (: <elem-type> ("jvm object null"))) array) + + (~~ (static @.js)) + ("js array delete" index array)})) array)) ) diff --git a/stdlib/source/lux/data/collection/tree/zipper.lux b/stdlib/source/lux/data/collection/tree/zipper.lux index f6a8ad8f0..cf6020ffe 100644 --- a/stdlib/source/lux/data/collection/tree/zipper.lux +++ b/stdlib/source/lux/data/collection/tree/zipper.lux @@ -98,16 +98,14 @@ (: (-> (Tree ($ 0)) (Tree ($ 0))) (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) (#.Cons (get@ #node zipper) - (get@ #rights zipper))))) - - (~~ (static @.jvm)) - (:share [a] - {(Zipper a) - zipper} - {(-> (Tree a) (Tree a)) - (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) - (#.Cons (get@ #node zipper) - (get@ #rights zipper))))})})) + (get@ #rights zipper)))))} + (:share [a] + {(Zipper a) + zipper} + {(-> (Tree a) (Tree a)) + (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) + (#.Cons (get@ #node zipper) + (get@ #rights zipper))))}))) parent))) (def: #export (start zipper) @@ -203,10 +201,8 @@ (function (_ children) (list& (`` (for {(~~ (static @.old)) (: (Tree ($ 0)) - (//.tree [value {}])) - - (~~ (static @.jvm)) - (//.tree [value {}])})) + (//.tree [value {}]))} + (//.tree [value {}]))) children)) zipper)) @@ -217,10 +213,8 @@ (list@compose children (list (`` (for {(~~ (static @.old)) (: (Tree ($ 0)) - (//.tree [value {}])) - - (~~ (static @.jvm)) - (//.tree [value {}])}))))) + (//.tree [value {}]))} + (//.tree [value {}])))))) zipper)) (def: #export (remove zipper) @@ -252,10 +246,8 @@ (update@ <side> (function (_ side) (#.Cons (`` (for {(~~ (static @.old)) (: (Tree ($ 0)) - (//.tree [value {}])) - - (~~ (static @.jvm)) - (//.tree [value {}])})) + (//.tree [value {}]))} + (//.tree [value {}]))) side)))))))] [insert-left #lefts] @@ -270,21 +262,19 @@ #node (//@map f (get@ #node fa))})) (`` (for {(~~ (static @.old)) - (as-is) - - (~~ (static @.jvm)) - (structure: #export comonad (CoMonad Zipper) - (def: &functor ..functor) - - (def: unwrap (get@ [#node #//.value])) - - (def: (split [parent lefts rights node]) - (let [tree-splitter (: (All [a] (-> (Tree a) (Tree (Zipper a)))) - (function (tree-splitter tree) - {#//.value (zip tree) - #//.children (list@map tree-splitter - (get@ #//.children tree))}))] - {#parent (maybe@map split parent) - #lefts (list@map tree-splitter lefts) - #rights (list@map tree-splitter rights) - #node (tree-splitter node)})))})) + (as-is)} + (structure: #export comonad (CoMonad Zipper) + (def: &functor ..functor) + + (def: unwrap (get@ [#node #//.value])) + + (def: (split [parent lefts rights node]) + (let [tree-splitter (: (All [a] (-> (Tree a) (Tree (Zipper a)))) + (function (tree-splitter tree) + {#//.value (zip tree) + #//.children (list@map tree-splitter + (get@ #//.children tree))}))] + {#parent (maybe@map split parent) + #lefts (list@map tree-splitter lefts) + #rights (list@map tree-splitter rights) + #node (tree-splitter node)}))))) diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux index 7fd2a3420..ecca052e2 100644 --- a/stdlib/source/lux/host.js.lux +++ b/stdlib/source/lux/host.js.lux @@ -1,24 +1,25 @@ (.module: [lux #* - [abstract - monad] [control ["p" parser ["s" code (#+ Parser)]]] [data [collection - ["." list #* ("#;." fold)]]] + ["." list ("#@." fold)]]] + [type + abstract] [macro (#+ with-gensyms) - ["." code] - [syntax (#+ syntax:)]]]) + [syntax (#+ syntax:)] + ["." code]]]) (template [<name> <type>] - [(type: #export <name> (#.Primitive <type> #.Nil))] + [(abstract: #export <name> {} Any)] - [Object "object"] - [Function "function"] - [Symbol "symbol"] - [Undefined "undefined"] + [Object] + [Function] + [Symbol] + [Null] + [Undefined] ) (template [<name> <type>] @@ -28,62 +29,3 @@ [Number Frac] [Boolean Bit] ) - -## [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 (` ("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 (` ("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" (-> Frac Frac) (ref "Math")))} - (wrap (list (` (:coerce (~ type) - ("js get-field" (~ object) (~ field-name))))))) - -(syntax: #export (object {kvs (p.some (p.and s.any s.any))}) - {#.doc (doc "A way to create JavaScript objects." - (object) - (object "foo" foo "bar" (inc bar)))} - (wrap (list (list;fold (function (_ [k v] object) - (` (set! (~ k) (~ v) (~ object)))) - (` ("js object")) - kvs)))) - -(syntax: #export (ref {name s.text} - {type (p.maybe s.any)}) - {#.doc (doc "A way to refer to JavaScript variables." - (ref "document") - (ref "Math.ceil" (-> Frac Frac)))} - (wrap (list (` (:coerce (~ (default (' ..Object) type)) - ("js ref" (~ (code.text name)))))))) - -(template [<name> <proc> <doc>] - [(syntax: #export (<name>) - {#.doc (doc <doc> - (<name>))} - (wrap (list (` (<proc>)))))] - - [null "js null" "Null object reference."] - [undef "js undefined" "Undefined."] - ) - -(syntax: #export (call! {shape (p.or ($_ p.and s.any (s.tuple (p.some s.any)) (p.maybe s.any)) - ($_ p.and s.any s.text (s.tuple (p.some s.any)) (p.maybe 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 (` (:coerce (~ (default (' ..Object) ?type)) - ("js call" (~ function) (~+ args)))))) - - (#.Right [object field args ?type]) - (wrap (list (` (:coerce (~ (default (' ..Object) ?type)) - ("js object-call" (~ object) (~ (code.text field)) (~+ args)))))))) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index 1340f31d0..41627aca9 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -66,7 +66,31 @@ (-> Frac Frac Frac) (|> ("jvm member invoke static" "java.lang.Math" "pow" ["D" (!double subject)] ["D" (!double param)]) - !frac)))})) + !frac))) + + (~~ (static @.js)) + (as-is (template [<name> <method>] + [(def: #export <name> + (-> Frac Frac) + (|>> ("js apply" ("js constant" <method>)) (:coerce Frac)))] + + [cos "Math.cos"] + [sin "Math.sin"] + [tan "Math.tan"] + + [acos "Math.acos"] + [asin "Math.asin"] + [atan "Math.atan"] + + [exp "Math.exp"] + [log "Math.log"] + + [ceil "Math.ceil"] + [floor "Math.floor"] + ) + (def: #export (pow param subject) + (-> Frac Frac Frac) + (:coerce Frac ("js apply" ("js constant" "Math.pow") subject param))))})) (def: #export (round input) (-> Frac Frac) diff --git a/stdlib/source/lux/target/js.lux b/stdlib/source/lux/target/js.lux index c34f806f8..526621236 100644 --- a/stdlib/source/lux/target/js.lux +++ b/stdlib/source/lux/target/js.lux @@ -276,14 +276,14 @@ (-> Var Expression Statement) (:abstraction (format "var " (:representation name) " = " (:representation value) ..statement-suffix))) - (def: #export (set name value) - (-> Location Expression Statement) - (:abstraction (format (:representation name) " = " (:representation value) ..statement-suffix))) - (def: #export (set' name value) (-> Location Expression Expression) (:abstraction (..argument (format (:representation name) " = " (:representation value))))) + (def: #export (set name value) + (-> Location Expression Statement) + (:abstraction (format (:representation (set' name value)) ..statement-suffix))) + (def: #export (throw message) (-> Expression Statement) (:abstraction (format "throw " (:representation message) ..statement-suffix))) @@ -292,9 +292,13 @@ (-> Expression Statement) (:abstraction (format "return " (:representation value) ..statement-suffix))) + (def: #export (delete' value) + (-> Location Expression) + (:abstraction (format "delete " (:representation value)))) + (def: #export (delete value) (-> Location Statement) - (:abstraction (format "delete " (:representation value) ..statement-suffix))) + (:abstraction (format (:representation (delete' value)) ..statement-suffix))) (def: #export (if test then! else!) (-> Expression Statement Statement Statement) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index 1f650634f..1a8d10474 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -19,7 +19,7 @@ ["." // ["#." syntax (#+ Aliases)] ["#." evaluation] - ["#/" // (#+ Instancer) + ["/#" // (#+ Instancer) ["#." analysis] ["#." synthesis] ["#." statement (#+ Requirements)] @@ -48,10 +48,11 @@ #.version //.version #.mode #.Build}) -(def: #export (state target expander host generate generation-bundle host-statement-bundle program) +(def: #export (state target expander host-analysis host generate generation-bundle host-statement-bundle program) (All [anchor expression statement] (-> Text Expander + ///analysis.Bundle (generation.Host expression statement) (generation.Phase anchor expression statement) (generation.Bundle anchor expression statement) @@ -61,8 +62,9 @@ (let [synthesis-state [synthesisE.bundle ///synthesis.init] generation-state [generation-bundle (generation.state host)] eval (//evaluation.evaluator expander synthesis-state generation-state generate) - analysis-state [(analysisE.bundle eval) (///analysis.state (..info target) host)]] - [(dictionary.merge (luxS.bundle expander program) + analysis-state [(analysisE.bundle eval host-analysis) + (///analysis.state (..info target) host)]] + [(dictionary.merge (luxS.bundle expander host-analysis program) host-statement-bundle) {#///statement.analysis {#///statement.state analysis-state #///statement.phase (analysisP.phase expander)} diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 5dc5105f2..3e086e813 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -16,7 +16,7 @@ ["." // #_ ["#." init] ["#." syntax] - ["#/" // + ["/#" // ["#." analysis] ["#." statement] ["#." phase @@ -56,10 +56,11 @@ <State+> (as-is (///statement.State+ anchor expression statement)) <Bundle> (as-is (generation.Bundle anchor expression statement))] - (def: #export (initialize target expander platform generation-bundle host-statement-bundle program) + (def: #export (initialize target expander host-analysis platform generation-bundle host-statement-bundle program) (All <type-vars> (-> Text Expander + ///analysis.Bundle <Platform> <Bundle> (///statement.Bundle anchor expression statement) @@ -70,6 +71,7 @@ ///statement.lift-generation (///phase.run' (//init.state target expander + host-analysis (get@ #host platform) (get@ #phase platform) generation-bundle @@ -104,9 +106,9 @@ ## (io.fail error)) ) - (def: #export (compile expander platform configuration archive state) + (def: #export (compile partial-host-extension expander platform configuration archive state) (All <type-vars> - (-> Expander <Platform> Configuration Archive <State+> (! (Error [Archive <State+>])))) + (-> Text Expander <Platform> Configuration Archive <State+> (! (Error [Archive <State+>])))) (let [monad (get@ #&monad platform) source-module (get@ #cli.module configuration) compiler (:share [anchor expression statement] @@ -128,6 +130,7 @@ [input (context.read monad (get@ #&file-system platform) (get@ #cli.sources configuration) + partial-host-extension module) ## _ (&io.prepare-module target-dir (get@ #cli.module configuration)) ## _ (write-module target-dir file-name (get@ #cli.module configuration) module outputs) diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux index bd1efd73b..454487cce 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/context.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/context.lux @@ -36,23 +36,6 @@ Extension ".lux") -(def: partial-host-extension - Extension - (`` (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 - (format partial-host-extension lux-extension)) - (def: #export (path system context module) (All [m] (-> (file.System m) Context Module Path)) (|> module @@ -78,22 +61,23 @@ (#error.Failure error) (find-source-file monad system contexts' module extension))))) -(def: #export (find-any-source-file monad system contexts module) +(def: #export (find-any-source-file monad system contexts partial-host-extension module) (All [!] - (-> (Monad !) (file.System !) (List Context) Module + (-> (Monad !) (file.System !) (List Context) Text Module (! (Error [Path (File !)])))) - (do monad - [outcome (find-source-file monad system contexts module ..full-host-extension)] - (case outcome - (#error.Success output) - (wrap outcome) + (let [full-host-extension (format partial-host-extension lux-extension)] + (do monad + [outcome (find-source-file monad system contexts module full-host-extension)] + (case outcome + (#error.Success output) + (wrap outcome) - (#error.Failure error) - (find-source-file monad system contexts module ..lux-extension)))) + (#error.Failure error) + (find-source-file monad system contexts module ..lux-extension))))) -(def: #export (read monad system contexts module) +(def: #export (read monad system contexts partial-host-extension module) (All [!] - (-> (Monad !) (file.System !) (List Context) Module + (-> (Monad !) (file.System !) (List Context) Text Module (! (Error Input)))) (do (error.with monad) [## TODO: Get rid of both ":share"s ASAP @@ -101,7 +85,7 @@ {(Monad !) monad} {(! (Error [Path (File !)])) - (find-any-source-file monad system contexts module)}) + (find-any-source-file monad system contexts partial-host-extension module)}) #let [[path file] (:share [!] {(Monad !) monad} diff --git a/stdlib/source/lux/tool/compiler/name.lux b/stdlib/source/lux/tool/compiler/name.lux index 252d57051..093d934cb 100644 --- a/stdlib/source/lux/tool/compiler/name.lux +++ b/stdlib/source/lux/tool/compiler/name.lux @@ -30,7 +30,8 @@ ["<"] "_LT" [">"] "_GT" ["~"] "_TI" - ["|"] "_PI"] + ["|"] "_PI" + [" "] "_SP"] (text.from-code char)))) (def: #export (normalize name) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux index 694f0345f..df378eebf 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux @@ -1,20 +1,16 @@ -(.`` (.module: - [lux #* - ["@" target] - [data - [collection - ["." dictionary]]]] - [//// - [default - [evaluation (#+ Eval)]] - [analysis (#+ Bundle)]] - ["." / #_ - ["#." lux] - ["#." (~~ (.for {"{old}" jvm - "JVM" jvm}))]])) +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [//// + [default + [evaluation (#+ Eval)]] + [analysis (#+ Bundle)]] + ["." / #_ + ["#." lux]]) -(def: #export (bundle eval) - (-> Eval Bundle) - (dictionary.merge (`` (for {(~~ (static @.old)) /jvm.bundle - (~~ (static @.jvm)) /jvm.bundle})) +(def: #export (bundle eval host-specific) + (-> Eval Bundle Bundle) + (dictionary.merge host-specific (/lux.bundle eval))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/js.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/js.lux new file mode 100644 index 000000000..d8285532b --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/js.lux @@ -0,0 +1,146 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]] + pipe] + [data + [collection + ["." array (#+ Array)] + ["." dictionary]]] + [type + ["." check]] + [target + ["_" js]]] + ["." // #_ + ["#." lux (#+ custom)] + ["/#" // + ["#." bundle] + ["/#" // ("#@." monad) + [analysis + [".A" type]] + ["/#" // #_ + ["#." analysis (#+ Analysis Operation Phase Handler Bundle)]]]]]) + +(def: array::new + Handler + (custom + [<c>.any + (function (_ extension phase lengthC) + (do ////.monad + [lengthA (typeA.with-type Nat + (phase lengthC)) + [var-id varT] (typeA.with-env check.var) + _ (typeA.infer (type (Array varT)))] + (wrap (#/////analysis.Extension extension (list lengthA)))))])) + +(def: array::length + Handler + (custom + [<c>.any + (function (_ extension phase arrayC) + (do ////.monad + [[var-id varT] (typeA.with-env check.var) + arrayA (typeA.with-type (type (Array varT)) + (phase arrayC)) + _ (typeA.infer Nat)] + (wrap (#/////analysis.Extension extension (list arrayA)))))])) + +(def: array::read + Handler + (custom + [(<>.and <c>.any <c>.any) + (function (_ extension phase [indexC arrayC]) + (do ////.monad + [indexA (typeA.with-type Nat + (phase indexC)) + [var-id varT] (typeA.with-env check.var) + arrayA (typeA.with-type (type (Array varT)) + (phase arrayC)) + _ (typeA.infer varT)] + (wrap (#/////analysis.Extension extension (list indexA arrayA)))))])) + +(def: array::write + Handler + (custom + [($_ <>.and <c>.any <c>.any <c>.any) + (function (_ extension phase [indexC valueC arrayC]) + (do ////.monad + [indexA (typeA.with-type Nat + (phase indexC)) + [var-id varT] (typeA.with-env check.var) + valueA (typeA.with-type varT + (phase valueC)) + arrayA (typeA.with-type (type (Array varT)) + (phase arrayC)) + _ (typeA.infer (type (Array varT)))] + (wrap (#/////analysis.Extension extension (list indexA valueA arrayA)))))])) + +(def: array::delete + Handler + (custom + [($_ <>.and <c>.any <c>.any) + (function (_ extension phase [indexC arrayC]) + (do ////.monad + [indexA (typeA.with-type Nat + (phase indexC)) + [var-id varT] (typeA.with-env check.var) + arrayA (typeA.with-type (type (Array varT)) + (phase arrayC)) + _ (typeA.infer (type (Array varT)))] + (wrap (#/////analysis.Extension extension (list indexA arrayA)))))])) + +(def: bundle::array + Bundle + (<| (///bundle.prefix "array") + (|> ///bundle.empty + (///bundle.install "new" array::new) + (///bundle.install "length" array::length) + (///bundle.install "read" array::read) + (///bundle.install "write" array::write) + (///bundle.install "delete" array::delete) + ))) + +(def: js::constant + Handler + (custom + [<c>.text + (function (_ extension phase name) + (do ////.monad + [_ (typeA.infer Any)] + (wrap (#/////analysis.Extension extension (list (/////analysis.text name))))))])) + +(def: js::apply + Handler + (custom + [($_ <>.and <c>.any (<>.some <c>.any)) + (function (_ extension phase [abstractionC inputsC]) + (do ////.monad + [abstractionA (typeA.with-type Any + (phase abstractionC)) + inputsA (monad.map @ (|>> phase (typeA.with-type Any)) inputsC) + _ (typeA.infer Any)] + (wrap (#/////analysis.Extension extension (list& abstractionA inputsA)))))])) + +(def: js::undefined? + Handler + (custom + [<c>.any + (function (_ extension phase [valueC]) + (do ////.monad + [valueA (typeA.with-type Any + (phase valueC)) + _ (typeA.infer Bit)] + (wrap (#/////analysis.Extension extension (list valueA)))))])) + +(def: #export bundle + Bundle + (<| (///bundle.prefix "js") + (|> ///bundle.empty + (///bundle.install "constant" js::constant) + (///bundle.install "apply" js::apply) + (///bundle.install "undefined?" js::undefined?) + (dictionary.merge bundle::array) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/lux.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/lux.lux index 51402fad8..48401f0c6 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/lux.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/lux.lux @@ -90,31 +90,32 @@ _ (<>.fail (exception.construct ..char-text-must-be-size-1 [raw]))))) (def: lux::syntax-char-case! - (..custom [($_ <>.and - <c>.any - (<c>.tuple (<>.some (<>.and (<c>.tuple (<>.many ..text-char)) - <c>.any))) - <c>.any) - (function (_ extension-name phase [input conditionals else]) - (do ////.monad - [input (typeA.with-type text.Char - (phase input)) - expectedT (///.lift macro.expected-type) - conditionals (monad.map @ (function (_ [cases branch]) - (do @ - [branch (typeA.with-type expectedT - (phase branch))] - (wrap [cases branch]))) - conditionals) - else (typeA.with-type expectedT - (phase else))] - (wrap (|> conditionals - (list@map (function (_ [cases branch]) - (/////analysis.tuple - (list (/////analysis.tuple (list@map (|>> /////analysis.nat) cases)) - branch)))) - (list& input else) - (#/////analysis.Extension extension-name)))))]))) + (..custom + [($_ <>.and + <c>.any + (<c>.tuple (<>.some (<>.and (<c>.tuple (<>.many ..text-char)) + <c>.any))) + <c>.any) + (function (_ extension-name phase [input conditionals else]) + (do ////.monad + [input (typeA.with-type text.Char + (phase input)) + expectedT (///.lift macro.expected-type) + conditionals (monad.map @ (function (_ [cases branch]) + (do @ + [branch (typeA.with-type expectedT + (phase branch))] + (wrap [cases branch]))) + conditionals) + else (typeA.with-type expectedT + (phase else))] + (wrap (|> conditionals + (list@map (function (_ [cases branch]) + (/////analysis.tuple + (list (/////analysis.tuple (list@map (|>> /////analysis.nat) cases)) + branch)))) + (list& input else) + (#/////analysis.Extension extension-name)))))]))) ## "lux is" represents reference/pointer equality. (def: lux::is diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux index 0ae210fa5..af49f8ee1 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux @@ -127,9 +127,9 @@ (synthesize codeA))] (definition' generate name code//type codeS))) -(def: (refresh expander) +(def: (refresh expander host-analysis) (All [anchor expression statement] - (-> Expander (Operation anchor expression statement Any))) + (-> Expander /////analysis.Bundle (Operation anchor expression statement Any))) (do ////.monad [[bundle state] ////.get-state #let [eval (/////evaluation.evaluator expander @@ -140,11 +140,11 @@ (update@ [#/////statement.analysis #/////statement.state] (: (-> /////analysis.State+ /////analysis.State+) (|>> product.right - [(///analysis.bundle eval)])) + [(///analysis.bundle eval host-analysis)])) state)]))) -(def: (lux::def expander) - (-> Expander Handler) +(def: (lux::def expander host-analysis) + (-> Expander /////analysis.Bundle Handler) (function (_ extension-name phase inputsC+) (case inputsC+ (^ (list [_ (#.Identifier ["" short-name])] valueC annotationsC [_ (#.Bit exported?)])) @@ -160,14 +160,14 @@ #let [_ (log! (format "Definition " (%name full-name)))] _ (/////statement.lift-generation (////generation.learn full-name valueN)) - _ (..refresh expander)] + _ (..refresh expander host-analysis)] (wrap /////statement.no-requirements)) _ (////.throw ///.invalid-syntax [extension-name %code inputsC+])))) -(def: (def::type-tagged expander) - (-> Expander Handler) +(def: (def::type-tagged expander host-analysis) + (-> Expander /////analysis.Bundle Handler) (..custom [($_ p.and s.local-identifier s.any s.any (s.tuple (p.some s.text)) s.bit) (function (_ extension-name phase [short-name valueC annotationsC tags exported?]) @@ -185,7 +185,7 @@ #let [_ (log! (format "Definition " (%name full-name)))] _ (/////statement.lift-generation (////generation.learn full-name valueN)) - _ (..refresh expander)] + _ (..refresh expander host-analysis)] (wrap /////statement.no-requirements)))])) (def: imports @@ -323,14 +323,14 @@ _ (////.throw ///.invalid-syntax [extension-name %code inputsC+])))) -(def: (bundle::def expander program) +(def: (bundle::def expander host-analysis program) (All [anchor expression statement] - (-> Expander (-> expression statement) (Bundle anchor expression statement))) + (-> Expander /////analysis.Bundle (-> expression statement) (Bundle anchor expression statement))) (<| (///bundle.prefix "def") (|> ///bundle.empty (dictionary.put "module" def::module) (dictionary.put "alias" def::alias) - (dictionary.put "type tagged" (def::type-tagged expander)) + (dictionary.put "type tagged" (def::type-tagged expander host-analysis)) (dictionary.put "analysis" def::analysis) (dictionary.put "synthesis" def::synthesis) (dictionary.put "generation" def::generation) @@ -338,10 +338,10 @@ (dictionary.put "program" (def::program program)) ))) -(def: #export (bundle expander program) +(def: #export (bundle expander host-analysis program) (All [anchor expression statement] - (-> Expander (-> expression statement) (Bundle anchor expression statement))) + (-> Expander /////analysis.Bundle (-> expression statement) (Bundle anchor expression statement))) (<| (///bundle.prefix "lux") (|> ///bundle.empty - (dictionary.put "def" (lux::def expander)) - (dictionary.merge (..bundle::def expander program))))) + (dictionary.put "def" (lux::def expander host-analysis)) + (dictionary.merge (..bundle::def expander host-analysis program))))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/extension.lux index 3bc0a0887..71739bfc9 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/extension.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/extension.lux @@ -6,8 +6,10 @@ [// [runtime (#+ Bundle)]] [/ - ["." common]]) + ["." common] + ["." host]]) (def: #export bundle Bundle - common.bundle) + (dictionary.merge common.bundle + host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux new file mode 100644 index 000000000..3cf3c6c07 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux @@ -0,0 +1,106 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." error] + [collection + ["." dictionary]]] + [target + ["_" js (#+ Expression)]]] + ["." // #_ + ["#." common] + ["/#" // #_ + ["#." runtime (#+ Operation Phase Handler Bundle + with-vars)] + ["#." primitive] + ["/#" // #_ + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["/#" // + ["." extension + ["." bundle]] + [// + [synthesis (#+ %synthesis)]]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase s (Operation Expression))] + Handler)) + (function (_ extension-name phase input) + (case (<s>.run input parser) + (#error.Success input') + (handler extension-name phase input') + + (#error.Failure error) + (/////.throw extension.invalid-syntax [extension-name %synthesis input])))) + +(def: array::new + (Unary Expression) + (|>> ///runtime.i64//to-number list (_.new (_.var "Array")))) + +(def: array::length + (Unary Expression) + (|>> (_.the "length") ///runtime.i64//from-number)) + +(def: (array::read [indexG arrayG]) + (Binary Expression) + (_.at indexG arrayG)) + +(def: (array::write [indexG valueG arrayG]) + (Trinary Expression) + (///runtime.array//write indexG valueG arrayG)) + +(def: (array::delete [indexG arrayG]) + (Binary Expression) + (///runtime.array//delete indexG arrayG)) + +(def: array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" (unary array::new)) + (bundle.install "length" (unary array::length)) + (bundle.install "read" (binary array::read)) + (bundle.install "write" (trinary array::write)) + (bundle.install "delete" (binary array::delete)) + ))) + +(def: js::constant + (..custom + [<s>.text + (function (_ extension phase name) + (do /////.monad + [] + (wrap (_.var name))))])) + +(def: js::apply + (..custom + [($_ <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase [abstractionS inputsS]) + (do /////.monad + [abstractionG (phase abstractionS) + inputsG (monad.map @ phase inputsS)] + (wrap (_.apply/* abstractionG inputsG))))])) + +(def: js::undefined? + (..custom + [<s>.any + (function (_ extension phase valueS) + (|> valueS + phase + (:: /////.monad map (_.= _.undefined))))])) + +(def: #export bundle + Bundle + (<| (bundle.prefix "js") + (|> bundle.empty + (bundle.install "constant" js::constant) + (bundle.install "apply" js::apply) + (bundle.install "undefined?" js::undefined?) + (dictionary.merge ..array) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux index 6892879b8..9be09d142 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux @@ -696,14 +696,6 @@ @js//delete )) -(runtime: (array//read idx array) - (with-vars [temp] - ($_ _.then - (_.define temp (_.at idx array)) - (_.if (_.= _.undefined temp) - (_.return ..none) - (_.return (..some temp)))))) - (runtime: (array//write idx value array) ($_ _.then (_.set (_.at idx array) value) @@ -717,7 +709,6 @@ (def: runtime//array Statement ($_ _.then - @array//read @array//write @array//delete)) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index 7db076162..506702706 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -25,6 +25,7 @@ ["." console]] [tool [compiler + ["." analysis] ["." statement] ["." phase [macro (#+ Expander)] @@ -78,10 +79,12 @@ (#error.Failure error) (:: io.monad wrap (#error.Failure error))))) -(def: #export (compiler target expander platform generation-bundle host-statement-bundle program service) +(def: #export (compiler target partial-host-extension expander host-analysis platform generation-bundle host-statement-bundle program service) (All [anchor expression statement] (-> Text + Text Expander + analysis.Bundle (IO (Platform IO anchor expression statement)) (generation.Bundle anchor expression statement) (statement.Bundle anchor expression statement) @@ -99,12 +102,12 @@ {(Platform IO anchor expression statement) platform} {(IO (Error (statement.State+ anchor expression statement))) - (platform.initialize target expander platform generation-bundle host-statement-bundle program)}) + (platform.initialize target expander host-analysis platform generation-bundle host-statement-bundle program)}) [archive state] (:share [anchor expression statement] {(Platform IO anchor expression statement) platform} {(IO (Error [Archive (statement.State+ anchor expression statement)])) - (platform.compile expander platform configuration archive.empty state)}) + (platform.compile partial-host-extension expander platform configuration archive.empty state)}) _ (save-artifacts! (get@ #platform.&file-system platform) state) ## _ (cache/io.clean target ...) ] diff --git a/stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux b/stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux index 8291794d5..2775e1e51 100644 --- a/stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux +++ b/stdlib/source/test/lux/tool/compiler/phase/analysis/primitive.lux @@ -22,7 +22,8 @@ ["/#" // [macro (#+ Expander)] [extension - ["#." analysis]] + ["#." analysis + ["." jvm]]] ["/#" // ["#." analysis (#+ Analysis Operation)] [default @@ -44,7 +45,8 @@ (def: #export state ////analysis.State+ - [(///analysis.bundle ..eval) (////analysis.state (init.info @.jvm) [])]) + [(///analysis.bundle ..eval jvm.bundle) + (////analysis.state (init.info @.jvm) [])]) (def: #export primitive (Random [Type Code]) |