aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--new-luxc/source/luxc/io.jvm.lux73
-rw-r--r--new-luxc/source/luxc/lang.lux12
-rw-r--r--new-luxc/source/luxc/lang/analysis/case.lux2
-rw-r--r--new-luxc/source/luxc/lang/analysis/expression.lux28
-rw-r--r--new-luxc/source/luxc/lang/analysis/reference.lux13
-rw-r--r--new-luxc/source/luxc/lang/analysis/structure.lux32
-rw-r--r--new-luxc/source/luxc/lang/host.jvm.lux8
-rw-r--r--new-luxc/source/luxc/lang/module.lux72
-rw-r--r--new-luxc/source/luxc/lang/translation.lux160
-rw-r--r--new-luxc/source/luxc/lang/translation/common.jvm.lux10
-rw-r--r--new-luxc/source/luxc/lang/translation/eval.jvm.lux15
-rw-r--r--new-luxc/source/luxc/lang/translation/function.jvm.lux2
-rw-r--r--new-luxc/source/luxc/lang/translation/imports.jvm.lux150
-rw-r--r--new-luxc/source/luxc/lang/translation/reference.jvm.lux4
-rw-r--r--new-luxc/source/luxc/lang/translation/statement.jvm.lux91
-rw-r--r--stdlib/source/lux/concurrency/actor.lux3
-rw-r--r--stdlib/source/lux/concurrency/atom.lux4
-rw-r--r--stdlib/source/lux/concurrency/promise.lux6
-rw-r--r--stdlib/source/lux/concurrency/stm.lux81
-rw-r--r--stdlib/source/lux/control/eq.lux4
-rw-r--r--stdlib/source/lux/data/lazy.lux18
-rw-r--r--stdlib/source/lux/host.jvm.lux2
-rw-r--r--stdlib/source/lux/lang/syntax.lux2
-rw-r--r--stdlib/source/lux/lang/type/check.lux10
-rw-r--r--stdlib/source/lux/macro.lux232
-rw-r--r--stdlib/source/lux/test.lux6
-rw-r--r--stdlib/source/lux/type/object.lux3
-rw-r--r--stdlib/test/test/lux/concurrency/atom.lux10
-rw-r--r--stdlib/test/test/lux/data/coll/dict.lux6
-rw-r--r--stdlib/test/test/lux/host.jvm.lux10
-rw-r--r--stdlib/test/test/lux/lang/syntax.lux48
31 files changed, 740 insertions, 377 deletions
diff --git a/new-luxc/source/luxc/io.jvm.lux b/new-luxc/source/luxc/io.jvm.lux
index 79a4ecfc5..21c3da256 100644
--- a/new-luxc/source/luxc/io.jvm.lux
+++ b/new-luxc/source/luxc/io.jvm.lux
@@ -2,7 +2,7 @@
lux
(lux (control monad
["ex" exception #+ exception:])
- [io #- run]
+ [io #+ Process]
(concurrency ["P" promise]
["T" task])
(data ["e" error]
@@ -21,24 +21,49 @@
(exception: #export File-Not-Found)
(exception: #export Module-Not-Found)
+(exception: #export Could-Not-Read-All-Data)
+
+(host;import #long java.io.File
+ (new [String])
+ (exists [] #io #try boolean)
+ (mkdir [] #io #try boolean)
+ (delete [] #io #try boolean)
+ (length [] #io #try long)
+ (listFiles [] #io #try (Array java.io.File))
+ (getAbsolutePath [] #io #try String)
+ (isFile [] #io #try boolean)
+ (isDirectory [] #io #try boolean))
+
+(host;import java.lang.AutoCloseable
+ (close [] #io #try void))
+
+(host;import java.io.InputStream
+ (read [(Array byte)] #io #try int))
+
+(host;import java.io.FileInputStream
+ (new [java.io.File] #io #try))
+
+(def: file-exists?
+ (-> File (Process Bool))
+ (|>. java.io.File.new (java.io.File.exists [])))
(def: (find-source path dirs)
- (-> Text (List File) (T;Task [Text File]))
+ (-> Text (List File) (Process [Text File]))
(case dirs
#;Nil
- (T;throw File-Not-Found path)
+ (io;fail (File-Not-Found path))
(#;Cons dir dirs')
- (do T;Monad<Task>
+ (do io;Monad<Process>
[#let [file (format dir "/" path)]
- ? (file;exists? file)]
+ ? (file-exists? file)]
(if ?
(wrap [path file])
(find-source path dirs')))))
(def: (either left right)
- (All [a] (-> (T;Task a) (T;Task a) (T;Task a)))
- (do P;Monad<Promise>
+ (All [a] (-> (Process a) (Process a) (Process a)))
+ (do io;Monad<IO>
[?output left]
(case ?output
(#e;Success output)
@@ -47,17 +72,30 @@
(#e;Error error)
right)))
+(def: #export (read-file file)
+ (-> File (Process Blob))
+ (do io;Monad<Process>
+ [#let [file' (java.io.File.new file)]
+ size (java.io.File.length [] file')
+ #let [data (blob;create (int-to-nat size))]
+ stream (FileInputStream.new [file'])
+ bytes-read (InputStream.read [data] stream)
+ _ (AutoCloseable.close [] stream)]
+ (if (i.= size bytes-read)
+ (wrap data)
+ (io;fail (Could-Not-Read-All-Data file)))))
+
(def: #export (read-module dirs name)
- (-> (List File) Text (T;Task [File Text]))
+ (-> (List File) Text (Process [File Text]))
(let [host-path (format name host-extension lux-extension)
lux-path (format name lux-extension)]
- (do T;Monad<Task>
- [[path file] (: (T;Task [Text File])
+ (do io;Monad<Process>
+ [[path file] (: (Process [Text File])
($_ either
(find-source host-path dirs)
(find-source lux-path dirs)
- (T;throw Module-Not-Found name)))
- blob (file;read file)]
+ (io;fail (Module-Not-Found name))))
+ blob (read-file file)]
(wrap [path (String.new blob)]))))
(def: #export (write-module name descriptor)
@@ -69,11 +107,6 @@
(format root-target "/" (for {"JVM" "jvm"
"JS" "js"})))
-(def: (platform-file root-file)
- (-> File File)
- (format root-file (for {"JVM" ".class"
- "JS" ".js"})))
-
(def: #export (prepare-target target-dir)
(-> File (T;Task Unit))
(do T;Monad<Task>
@@ -89,6 +122,6 @@
(def: #export (write-file target-dir file-name content)
(-> File Text Blob (T;Task Unit))
- (file;write content
- (format (platform-target target-dir)
- "/" (platform-file file-name))))
+ (|> file-name
+ (format (platform-target target-dir) "/")
+ (file;write content)))
diff --git a/new-luxc/source/luxc/lang.lux b/new-luxc/source/luxc/lang.lux
index 4aa47754a..b85409fb9 100644
--- a/new-luxc/source/luxc/lang.lux
+++ b/new-luxc/source/luxc/lang.lux
@@ -243,3 +243,15 @@
(if (n.= underflow idx)
output
(recur (n.dec idx) (format (|> (text;nth idx name) maybe;assume normalize-char) output)))))
+
+(exception: #export Error)
+
+(def: #export (with-error-tracking action)
+ (All [a] (-> (Meta a) (Meta a)))
+ (function [compiler]
+ (case (action compiler)
+ (#e;Error error)
+ ((throw Error error) compiler)
+
+ output
+ output)))
diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux
index 5d4c592aa..4a28ce436 100644
--- a/new-luxc/source/luxc/lang/analysis/case.lux
+++ b/new-luxc/source/luxc/lang/analysis/case.lux
@@ -239,7 +239,7 @@
(^ [cursor (#;Form (list& [_ (#;Tag tag)] values))])
(&;with-cursor cursor
(do macro;Monad<Meta>
- [tag (macro;normalize tag)
+ [tag (macro;canonical tag)
[idx group variantT] (macro;resolve-tag tag)
_ (&;with-type-env
(tc;check inputT variantT))]
diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux
index 5d38f7626..89fb3b93e 100644
--- a/new-luxc/source/luxc/lang/analysis/expression.lux
+++ b/new-luxc/source/luxc/lang/analysis/expression.lux
@@ -29,14 +29,14 @@
(def: #export (analyser eval)
(-> &;Eval &;Analyser)
(: (-> Code (Meta la;Analysis))
- (function analyse [ast]
+ (function analyse [code]
(do macro;Monad<Meta>
[expectedT macro;expected-type]
- (let [[cursor ast'] ast]
+ (let [[cursor code'] code]
## The cursor must be set in the compiler for the sake
## of having useful error messages.
(&;with-cursor cursor
- (case ast'
+ (case code'
(^template [<tag> <analyser>]
(<tag> value)
(<analyser> value))
@@ -83,16 +83,18 @@
(^ (#;Form (list& func args)))
(do macro;Monad<Meta>
- [[funcT =func] (commonA;with-unknown-type
+ [[funcT funcA] (commonA;with-unknown-type
(analyse func))]
- (case =func
+ (case funcA
[_ (#;Symbol def-name)]
(do @
- [[def-type def-anns def-value] (macro;find-def def-name)]
- (if (macro;macro? def-anns)
+ [?macro (&;with-error-tracking
+ (macro;find-macro def-name))]
+ (case ?macro
+ (#;Some macro)
(do @
[expansion (function [compiler]
- (case (macroL;expand (:! Macro def-value) args compiler)
+ (case (macroL;expand macro args compiler)
(#e;Success [compiler' output])
(#e;Success [compiler' output])
@@ -103,12 +105,14 @@
(analyse single)
_
- (&;throw Macro-Expression-Must-Have-Single-Expansion (%code ast))))
- (functionA;analyse-apply analyse funcT =func args)))
+ (&;throw Macro-Expression-Must-Have-Single-Expansion (%code code))))
+
+ _
+ (functionA;analyse-apply analyse funcT funcA args)))
_
- (functionA;analyse-apply analyse funcT =func args)))
+ (functionA;analyse-apply analyse funcT funcA args)))
_
- (&;throw Unrecognized-Syntax (%code ast))
+ (&;throw Unrecognized-Syntax (%code code))
)))))))
diff --git a/new-luxc/source/luxc/lang/analysis/reference.lux b/new-luxc/source/luxc/lang/analysis/reference.lux
index 25b33881c..7475f269f 100644
--- a/new-luxc/source/luxc/lang/analysis/reference.lux
+++ b/new-luxc/source/luxc/lang/analysis/reference.lux
@@ -13,9 +13,16 @@
(def: (analyse-definition def-name)
(-> Ident (Meta Analysis))
(do macro;Monad<Meta>
- [actualT (macro;find-def-type def-name)
- _ (&;infer actualT)]
- (wrap (code;symbol def-name))))
+ [[actualT def-anns _] (&;with-error-tracking
+ (macro;find-def def-name))]
+ (case (macro;get-symbol-ann (ident-for #;alias) def-anns)
+ (#;Some real-def-name)
+ (analyse-definition real-def-name)
+
+ _
+ (do @
+ [_ (&;infer actualT)]
+ (wrap (code;symbol def-name))))))
(def: (analyse-variable var-name)
(-> Text (Meta (Maybe Analysis)))
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux
index 2292d93cf..19eebbc46 100644
--- a/new-luxc/source/luxc/lang/analysis/structure.lux
+++ b/new-luxc/source/luxc/lang/analysis/structure.lux
@@ -235,7 +235,7 @@
(def: #export (analyse-tagged-sum analyse tag valueC)
(-> &;Analyser Ident Code (Meta la;Analysis))
(do macro;Monad<Meta>
- [tag (macro;normalize tag)
+ [tag (macro;canonical tag)
[idx group variantT] (macro;resolve-tag tag)
expectedT macro;expected-type]
(case expectedT
@@ -261,7 +261,7 @@
(case key
[_ (#;Tag key)]
(do macro;Monad<Meta>
- [key (macro;normalize key)]
+ [key (macro;canonical key)]
(wrap [key val]))
_
@@ -281,7 +281,7 @@
(#;Cons [head-k head-v] _)
(do macro;Monad<Meta>
- [head-k (macro;normalize head-k)
+ [head-k (macro;canonical head-k)
[_ tag-set recordT] (macro;resolve-tag head-k)
#let [size-record (list;size record)
size-ts (list;size tag-set)]
@@ -296,7 +296,7 @@
idx->val (monad;fold @
(function [[key val] idx->val]
(do @
- [key (macro;normalize key)]
+ [key (macro;canonical key)]
(case (dict;get key tag->idx)
#;None
(&;throw Tag-Does-Not-Belong-To-Record
@@ -323,14 +323,20 @@
(-> &;Analyser (List [Code Code]) (Meta la;Analysis))
(do macro;Monad<Meta>
[members (normalize members)
- [membersC recordT] (order members)
- expectedT macro;expected-type]
- (case expectedT
- (#;Var _)
- (do @
- [inferenceT (&inference;record recordT)
- [inferredT membersA] (&inference;general analyse inferenceT membersC)]
- (wrap (la;product membersA)))
+ [membersC recordT] (order members)]
+ (case membersC
+ (^ (list singletonC))
+ (analyse singletonC)
_
- (analyse-product analyse membersC))))
+ (do @
+ [expectedT macro;expected-type]
+ (case expectedT
+ (#;Var _)
+ (do @
+ [inferenceT (&inference;record recordT)
+ [inferredT membersA] (&inference;general analyse inferenceT membersC)]
+ (wrap (la;product membersA)))
+
+ _
+ (analyse-product analyse membersC))))))
diff --git a/new-luxc/source/luxc/lang/host.jvm.lux b/new-luxc/source/luxc/lang/host.jvm.lux
index 726bb5bbc..9f8fcd069 100644
--- a/new-luxc/source/luxc/lang/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/host.jvm.lux
@@ -3,7 +3,7 @@
(lux (control [monad #+ do]
["ex" exception #+ exception:]
pipe)
- (concurrency ["A" atom])
+ (concurrency [atom #+ Atom atom])
(data ["e" error]
[text]
text/format
@@ -62,11 +62,11 @@
(def: (fetch-byte-code class-name store)
(-> Text commonT;Class-Store (Maybe commonT;Bytecode))
- (|> store A;get io;run (dict;get class-name)))
+ (|> store atom;read io;run (dict;get class-name)))
(def: (memory-class-loader store)
(-> commonT;Class-Store ClassLoader)
- (object ClassLoader []
+ (object [] ClassLoader []
[]
(ClassLoader (findClass [class-name String]) Class
(case (fetch-byte-code class-name store)
@@ -85,7 +85,7 @@
(def: #export init-host
(io;IO commonT;Host)
(io;io (let [store (: commonT;Class-Store
- (A;atom (dict;new text;Hash<Text>)))]
+ (atom (dict;new text;Hash<Text>)))]
{#commonT;loader (memory-class-loader store)
#commonT;store store
#commonT;artifacts (dict;new text;Hash<Text>)
diff --git a/new-luxc/source/luxc/lang/module.lux b/new-luxc/source/luxc/lang/module.lux
index 2b855d927..f6cffa9c6 100644
--- a/new-luxc/source/luxc/lang/module.lux
+++ b/new-luxc/source/luxc/lang/module.lux
@@ -1,7 +1,8 @@
(;module:
lux
(lux (control [monad #+ do]
- ["ex" exception #+ exception:])
+ ["ex" exception #+ exception:]
+ pipe)
(data [text "text/" Eq<Text>]
text/format
["e" error]
@@ -15,6 +16,9 @@
(exception: #export Cannot-Declare-Tag-Twice)
(exception: #export Cannot-Declare-Tags-For-Unnamed-Type)
(exception: #export Cannot-Declare-Tags-For-Foreign-Type)
+(exception: #export Cannot-Define-More-Than-Once)
+(exception: #export Cannot-Define-In-Unknown-Module)
+(exception: #export Can-Only-Change-State-Of-Active-Module)
(def: (new-module hash)
(-> Nat Module)
@@ -27,6 +31,45 @@
#;module-annotations (' {})
#;module-state #;Active})
+(def: #export (set-annotations annotations)
+ (-> Code (Meta Unit))
+ (do macro;Monad<Meta>
+ [self macro;current-module-name]
+ (function [compiler]
+ (#e;Success [(update@ #;modules
+ (&;pl-update self (set@ #;module-annotations annotations))
+ compiler)
+ []]))))
+
+(def: #export (import module)
+ (-> Text (Meta Unit))
+ (do macro;Monad<Meta>
+ [self macro;current-module-name]
+ (function [compiler]
+ (#e;Success [(update@ #;modules
+ (&;pl-update self (update@ #;imports (|>. (#;Cons module))))
+ compiler)
+ []]))))
+
+(def: #export (alias alias module)
+ (-> Text Text (Meta Unit))
+ (do macro;Monad<Meta>
+ [self macro;current-module-name]
+ (function [compiler]
+ (#e;Success [(update@ #;modules
+ (&;pl-update self (update@ #;module-aliases (: (-> (List [Text Text]) (List [Text Text]))
+ (|>. (#;Cons [alias module])))))
+ compiler)
+ []]))))
+
+(def: #export (exists? module)
+ (-> Text (Meta Bool))
+ (function [compiler]
+ (|> (get@ #;modules compiler)
+ (&;pl-get module)
+ (case> (#;Some _) true #;None false)
+ [compiler] #e;Success)))
+
(def: #export (define (^@ full-name [module-name def-name])
definition)
(-> Ident Def (Meta Unit))
@@ -45,10 +88,10 @@
[]])
(#;Some already-existing)
- (#e;Error (format "Cannot re-define definiton: " (%ident full-name))))
+ ((&;throw Cannot-Define-More-Than-Once (%ident full-name)) compiler))
#;None
- (#e;Error (format "Cannot define in unknown module: " module-name)))))
+ ((&;throw Cannot-Define-In-Unknown-Module (%ident full-name)) compiler))))
(def: #export (create hash name)
(-> Nat Text (Meta Module))
@@ -64,11 +107,11 @@
(do macro;Monad<Meta>
[_ (create hash name)
output (&;with-current-module name
- (&scope;with-scope name action))
+ action)
module (macro;find-module name)]
(wrap [module output])))
-(do-template [<flagger> <asker> <tag>]
+(do-template [<flagger> <asker> <tag> <description>]
[(def: #export (<flagger> module-name)
(-> Text (Meta Unit))
(function [compiler]
@@ -82,10 +125,13 @@
(&;pl-put module-name (set@ #;module-state <tag> module))
compiler)
[]])
- (#e;Error "Can only change the state of a currently-active module.")))
+ ((&;throw Can-Only-Change-State-Of-Active-Module
+ (format " Module: " module-name "\n"
+ "Desired state: " <description>))
+ compiler)))
#;None
- (#e;Error (format "Module does not exist: " module-name)))))
+ ((&;throw Unknown-Module module-name) compiler))))
(def: #export (<asker> module-name)
(-> Text (Meta Bool))
(function [compiler]
@@ -97,12 +143,12 @@
_ false)])
#;None
- (#e;Error (format "Module does not exist: " module-name)))
+ ((&;throw Unknown-Module module-name) compiler))
))]
- [flag-active! active? #;Active]
- [flag-compiled! compiled? #;Compiled]
- [flag-cached! cached? #;Cached]
+ [flag-active! active? #;Active "Active"]
+ [flag-compiled! compiled? #;Compiled "Compiled"]
+ [flag-cached! cached? #;Cached "Cached"]
)
(do-template [<name> <tag> <type>]
@@ -114,7 +160,7 @@
(#e;Success [compiler (get@ <tag> module)])
#;None
- (macro;run compiler (&;throw Unknown-Module module-name)))
+ ((&;throw Unknown-Module module-name) compiler))
))]
[tags-by-module #;tags (List [Text [Nat (List Ident) Bool Type]])]
@@ -170,4 +216,4 @@
compiler)
[]]))
#;None
- (macro;run compiler (&;throw Unknown-Module current-module))))))
+ ((&;throw Unknown-Module current-module) compiler)))))
diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux
index dd84ad024..33f74795a 100644
--- a/new-luxc/source/luxc/lang/translation.lux
+++ b/new-luxc/source/luxc/lang/translation.lux
@@ -2,16 +2,18 @@
lux
(lux (control [monad #+ do]
["ex" exception #+ exception:])
- (concurrency ["T" task])
+ (concurrency ["P" promise]
+ ["T" task])
(data ["e" error]
[text "text/" Hash<Text>]
text/format
- (coll [dict]))
+ (coll [list]
+ [dict]))
[macro]
(lang [syntax]
(type ["tc" check]))
[host]
- [io]
+ [io #+ IO Process io]
(world [file #+ File]))
(luxc ["&" lang]
["&;" io]
@@ -26,7 +28,8 @@
[";T" statement]
[";T" common]
[";T" expression]
- [";T" eval])
+ [";T" eval]
+ [";T" imports])
["&;" eval])
))
@@ -36,6 +39,7 @@
(exception: #export Macro-Expansion-Failed)
(exception: #export Unrecognized-Statement)
+(exception: #export Invalid-Alias)
(def: (process-annotations annsC)
(-> Code (Meta [$;Inst Code]))
@@ -47,58 +51,92 @@
annsV (evalT;eval annsI)]
(wrap [annsI (:! Code annsV)])))
-(def: (translate code)
- (-> Code (Meta Unit))
- (case code
- (^code ("lux def" (~ [_ (#;Symbol ["" def-name])]) (~ valueC) (~ annsC)))
- (hostL;with-context def-name
- (&;with-fresh-type-env
- (do macro;Monad<Meta>
- [[annsI annsV] (process-annotations annsC)
- [_ valueT valueA] (&;with-scope
- (if (macro;type? (:! Code annsV))
- (do @
- [valueA (&;with-type Type
- (analyse valueC))]
- (wrap [Type valueA]))
- (commonA;with-unknown-type
- (analyse valueC))))
- valueT (&;with-type-env
- (tc;clean valueT))
- valueI (expressionT;translate (expressionS;synthesize valueA))
- _ (&;with-scope
- (statementT;translate-def def-name valueT valueI annsI annsV))]
- (wrap []))))
+(def: (switch-compiler new-compiler)
+ (-> Compiler (Meta Unit))
+ (function [old-compiler]
+ (#e;Success [new-compiler []])))
- (^code ("lux program" (~ [_ (#;Symbol ["" program-args])]) (~ programC)))
- (do macro;Monad<Meta>
- [[_ programA] (&;with-scope
- (&;with-type (type (io;IO Unit))
- (analyse programC)))
- programI (expressionT;translate (expressionS;synthesize programA))]
- (statementT;translate-program program-args programI))
+(def: (ensure-valid-alias def-name annotations value)
+ (-> Text Code Code (Meta Unit))
+ (case [annotations value]
+ (^multi [[_ (#;Record pairs)] [_ (#;Symbol _)]]
+ (|> pairs list;size (n.= +1)))
+ (:: macro;Monad<Meta> wrap [])
- (^code ("lux module" (~ annsC)))
- (do macro;Monad<Meta>
- [[annsI annsV] (process-annotations annsC)]
- (&;fail (%code annsV)))
+ _
+ (&;throw Invalid-Alias def-name)))
+(def: (translate translate-module code)
+ (-> (-> Text Compiler (Process Compiler)) Code (Meta Unit))
+ (case code
(^code ((~ [_ (#;Symbol macro-name)]) (~@ args)))
(do macro;Monad<Meta>
- [macro-name (macro;normalize macro-name)
- [def-type def-anns def-value] (macro;find-def macro-name)]
- (if (macro;macro? def-anns)
+ [?macro (&;with-error-tracking
+ (macro;find-macro macro-name))]
+ (case ?macro
+ (#;Some macro)
(do @
[expansion (function [compiler]
- (case (macroL;expand (:! Macro def-value) args compiler)
+ (case (macroL;expand macro args compiler)
(#e;Success [compiler' output])
(#e;Success [compiler' output])
(#e;Error error)
((&;throw Macro-Expansion-Failed error) compiler)))
- _ (monad;map @ translate expansion)]
+ _ (monad;map @ (translate translate-module) expansion)]
(wrap []))
+
+ #;None
(&;throw Unrecognized-Statement (%code code))))
+
+ (^code ("lux def" (~ [_ (#;Symbol ["" def-name])]) (~ valueC) (~ annsC)))
+ (hostL;with-context def-name
+ (&;with-fresh-type-env
+ (do macro;Monad<Meta>
+ [[annsI annsV] (process-annotations annsC)]
+ (case (macro;get-symbol-ann (ident-for #;alias) annsV)
+ (#;Some real-def)
+ (do @
+ [_ (ensure-valid-alias def-name annsV valueC)
+ _ (&;with-scope
+ (statementT;translate-def def-name Void id annsI annsV))]
+ (wrap []))
+
+ #;None
+ (do @
+ [[_ valueT valueA] (&;with-scope
+ (if (macro;type? (:! Code annsV))
+ (do @
+ [valueA (&;with-type Type
+ (analyse valueC))]
+ (wrap [Type valueA]))
+ (commonA;with-unknown-type
+ (analyse valueC))))
+ valueT (&;with-type-env
+ (tc;clean valueT))
+ valueI (expressionT;translate (expressionS;synthesize valueA))
+ _ (&;with-scope
+ (statementT;translate-def def-name valueT valueI annsI annsV))]
+ (wrap []))))))
+
+ (^code ("lux module" (~ annsC)))
+ (do macro;Monad<Meta>
+ [[annsI annsV] (process-annotations annsC)
+ process (importsT;translate-imports translate-module annsV)]
+ (case (io;run process)
+ (#e;Success compiler')
+ (switch-compiler compiler')
+
+ (#e;Error error)
+ (macro;fail error)))
+
+ (^code ("lux program" (~ [_ (#;Symbol ["" program-args])]) (~ programC)))
+ (do macro;Monad<Meta>
+ [[_ programA] (&;with-scope
+ (&;with-type (type (io;IO Unit))
+ (analyse programC)))
+ programI (expressionT;translate (expressionS;synthesize programA))]
+ (statementT;translate-program program-args programI))
_
(&;throw Unrecognized-Statement (%code code))))
@@ -126,10 +164,10 @@
_ (moduleL;flag-compiled! module-name)]
(wrap output)))
-(def: (parse current-module)
+(def: (read current-module)
(-> Text (Meta Code))
(function [compiler]
- (case (syntax;parse current-module (get@ #;source compiler))
+ (case (syntax;read current-module (get@ #;source compiler))
(#e;Error error)
(#e;Error error)
@@ -138,11 +176,13 @@
output]))))
(def: (translate-module source-dirs target-dir module-name compiler)
- (-> (List File) File Text Compiler (T;Task Compiler))
- (do T;Monad<Task>
- [_ (&io;prepare-module target-dir module-name)
+ (-> (List File) File Text Compiler (Process Compiler))
+ (do io;Monad<Process>
+ [#let [_ (log! (format "{translate-module} " module-name))]
+ ## _ (&io;prepare-module target-dir module-name)
[file-name file-content] (&io;read-module source-dirs module-name)
- #let [module-hash (text/hash file-content)]]
+ #let [module-hash (text/hash file-content)
+ translate-module (translate-module source-dirs target-dir)]]
(case (macro;run' compiler
(do macro;Monad<Meta>
[[_ artifacts _] (moduleL;with-module module-hash module-name
@@ -152,20 +192,21 @@
file-content]
(exhaust
(do @
- [code (parse module-name)
+ [code (read module-name)
#let [[cursor _] code]]
(&;with-cursor cursor
- (translate code)))))))]
+ (translate translate-module code)))))))]
(wrap artifacts)))
(#e;Success [compiler artifacts])
(do @
- [_ (monad;map @ (function [[class-name class-bytecode]]
- (&io;write-file target-dir class-name class-bytecode))
- (dict;entries artifacts))]
+ [## _ (monad;map @ (function [[class-name class-bytecode]]
+ ## (&io;write-file target-dir class-name class-bytecode))
+ ## (dict;entries artifacts))
+ ]
(wrap compiler))
(#e;Error error)
- (T;fail error))))
+ (io;fail error))))
(def: init-cursor Cursor ["" +1 +0])
@@ -177,7 +218,8 @@
(def: #export init-info
Info
- {#;target "JVM"
+ {#;target (for {"JVM" "JVM"
+ "JS" "JS"})
#;version &;version
#;mode #;Build})
@@ -205,11 +247,11 @@
(#e;Success [compiler [runtime-bc function-bc]])
(do @
[_ (&io;prepare-target target)
- _ (&io;write-file target hostL;runtime-class runtime-bc)
- _ (&io;write-file target hostL;function-class function-bc)]
+ _ (&io;write-file target (format hostL;runtime-class ".class") runtime-bc)
+ _ (&io;write-file target (format hostL;function-class ".class") function-bc)]
(wrap compiler)))
(: (T;Task Compiler))
- (:: @ map (translate-module sources target prelude)) (:: @ join)
- (:: @ map (translate-module sources target program)) (:: @ join))
+ (:: @ map (|>. (translate-module sources target prelude) P;future)) (:: @ join)
+ (:: @ map (|>. (translate-module sources target program) P;future)) (:: @ join))
#let [_ (log! "Compilation complete!")]]
(wrap [])))
diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux
index 49e135709..7a16a749a 100644
--- a/new-luxc/source/luxc/lang/translation/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux
@@ -2,7 +2,7 @@
[lux #- function]
(lux (control ["ex" exception #+ exception:])
[io]
- (concurrency ["A" atom])
+ (concurrency [atom #+ Atom atom])
(data ["e" error]
[text]
text/format
@@ -30,7 +30,7 @@
(type: #export Bytecode Blob)
-(type: #export Class-Store (A;Atom (Dict Text Bytecode)))
+(type: #export Class-Store (Atom (Dict Text Bytecode)))
(type: #export Artifacts (Dict File Blob))
@@ -84,16 +84,16 @@
(let [store (|> (get@ #;host compiler)
(:! Host)
(get@ #store))]
- (if (dict;contains? name (|> store A;get io;run))
+ (if (dict;contains? name (|> store atom;read io;run))
(ex;throw Class-Already-Stored name)
- (#e;Success [compiler (io;run (A;update (dict;put name byte-code) store))])
+ (#e;Success [compiler (io;run (atom;update (dict;put name byte-code) store))])
))))
(def: #export (load-class name)
(-> Text (Meta (Class Object)))
(;function [compiler]
(let [host (:! Host (get@ #;host compiler))
- store (|> host (get@ #store) A;get io;run)]
+ store (|> host (get@ #store) atom;read io;run)]
(if (dict;contains? name store)
(#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))])
(ex;throw Unknown-Class name)))))
diff --git a/new-luxc/source/luxc/lang/translation/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/eval.jvm.lux
index 11baa3856..6b9ee9743 100644
--- a/new-luxc/source/luxc/lang/translation/eval.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/eval.jvm.lux
@@ -1,7 +1,8 @@
(;module:
lux
(lux (control monad)
- (data text/format)
+ (data [text]
+ text/format)
[macro]
[host #+ do-to])
(luxc ["&" lang]
@@ -56,8 +57,10 @@
(def: #export (eval valueI)
(-> $;Inst (Meta Top))
(do macro;Monad<Meta>
- [class-name (:: @ map %code (macro;gensym "eval"))
- #let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
+ [current-module macro;current-module-name
+ class-name (:: @ map %code (macro;gensym (format current-module "/eval")))
+ #let [store-name (text;replace-all "/" "." class-name)
+ writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
(ClassWriter.visit [commonT;bytecode-version
(i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_SUPER)
class-name
@@ -70,11 +73,11 @@
"<clinit>"
($t;method (list) #;None (list))
(|>. valueI
- ($i;PUTSTATIC class-name commonT;value-field commonT;$Object)
+ ($i;PUTSTATIC store-name commonT;value-field commonT;$Object)
$i;RETURN)))
bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))]
- _ (commonT;store-class class-name bytecode)
- class (commonT;load-class class-name)]
+ _ (commonT;store-class store-name bytecode)
+ class (commonT;load-class store-name)]
(wrap (|> class
(Class.getField [commonT;value-field])
(Field.get (host;null))))))
diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux
index d8a2077bc..ab3382952 100644
--- a/new-luxc/source/luxc/lang/translation/function.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux
@@ -291,6 +291,8 @@
[function-class bodyI] (hostL;with-sub-context
(hostL;with-anchor [@begin +1]
(translate bodyS)))
+ this-module macro;current-module-name
+ #let [function-class (format (text;replace-all "/" "." this-module) "." function-class)]
[functionD instanceI] (with-function @begin function-class env arity bodyI)
_ (commonT;store-class function-class
($d;class #$;V1.6 #$;Public $;finalC
diff --git a/new-luxc/source/luxc/lang/translation/imports.jvm.lux b/new-luxc/source/luxc/lang/translation/imports.jvm.lux
new file mode 100644
index 000000000..c30f61225
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/imports.jvm.lux
@@ -0,0 +1,150 @@
+(;module:
+ lux
+ (lux (control [monad #+ do]
+ ["p" parser]
+ ["ex" exception #+ exception:]
+ pipe)
+ (concurrency [promise #+ Promise]
+ [stm #+ Var STM])
+ (data ["e" error #+ Error]
+ [maybe]
+ [product]
+ [text "text/" Eq<Text>]
+ text/format
+ (coll [list "list/" Functor<List> Fold<List>]
+ [dict #+ Dict]))
+ [macro]
+ (macro [code]
+ ["s" syntax])
+ [io #+ IO Process io]
+ [host])
+ (luxc ["&" lang]
+ (lang [";L" module])))
+
+(exception: #export Invalid-Imports)
+(exception: #export Module-Cannot-Import-Itself)
+(exception: #export Circular-Dependency)
+
+(host;import (java.util.concurrent.Future a)
+ (get [] #io a))
+
+(host;import (java.util.concurrent.CompletableFuture a)
+ (new [])
+ (complete [a] boolean)
+ (#static [a] completedFuture [a] (CompletableFuture a)))
+
+(type: Import
+ {#module Text
+ #alias Text})
+
+(def: import (s;Syntax Import) (s;tuple (p;seq s;text s;text)))
+
+(def: compilations
+ (Var (Dict Text (CompletableFuture (Error Compiler))))
+ (stm;var (dict;new text;Hash<Text>)))
+
+(def: (promise-to-future promise)
+ (All [a] (-> (Promise a) (Future a)))
+ (let [future (CompletableFuture.new [])]
+ (exec (:: promise;Functor<Promise> map
+ (function [value] (CompletableFuture.complete [value] future))
+ promise)
+ future)))
+
+(def: from-io
+ (All [a] (-> (IO a) (Process a)))
+ (:: io;Monad<IO> map (|>. #e;Success)))
+
+(def: (translate-dependency translate-module dependency compiler)
+ (-> (-> Text Compiler (Process Compiler))
+ (-> Text Compiler (IO (Future (Error Compiler)))))
+ (<| (Future.get [])
+ promise-to-future
+ (do promise;Monad<Promise>
+ [[new? future] (stm;commit (: (STM [Bool (CompletableFuture (Error Compiler))])
+ (do stm;Monad<STM>
+ [current-compilations (stm;read compilations)]
+ (case (dict;get dependency current-compilations)
+ (#;Some ongoing)
+ (wrap [false ongoing])
+
+ #;None
+ (do @
+ [#let [pending (: (CompletableFuture (Error Compiler))
+ (CompletableFuture.new []))]
+ _ (stm;write (dict;put dependency pending current-compilations)
+ compilations)]
+ (wrap [true pending]))))))]
+ (if new?
+ (exec (promise;future (io (CompletableFuture.complete [(io;run (translate-module dependency compiler))]
+ future)))
+ (wrap future))
+ (wrap future)))))
+
+(def: compiled?
+ (-> Module Bool)
+ (|>. (get@ #;module-state)
+ (case>
+ (^or #;Cached #;Compiled)
+ true
+
+ _
+ false)))
+
+(def: (merge-modules current-module from-dependency from-current)
+ (-> Text (List [Text Module]) (List [Text Module]) (List [Text Module]))
+ (|> from-dependency
+ (list;filter (|>. product;right compiled?))
+ (list/fold (function [[dep-name dep-module] total] (&;pl-put dep-name dep-module total))
+ from-current)))
+
+(def: (merge-compilers current-module dependency total)
+ (-> Text Compiler Compiler Compiler)
+ (|> total
+ (update@ #;modules (merge-modules current-module (get@ #;modules dependency)))
+ (set@ #;seed (get@ #;seed dependency))))
+
+(def: #export (translate-imports translate-module annotations)
+ (-> (-> Text Compiler (Process Compiler))
+ Code
+ (Meta (Process Compiler)))
+ (do macro;Monad<Meta>
+ [_ (moduleL;set-annotations annotations)
+ current-module macro;current-module-name
+ #let [_ (log! (format "{translate-imports} " current-module))]
+ imports (let [imports (|> (macro;get-tuple-ann (ident-for #;imports) annotations)
+ (maybe;default (list)))]
+ (case (s;run imports (p;some import))
+ (#e;Success imports)
+ (wrap imports)
+
+ (#e;Error error)
+ (&;throw Invalid-Imports (%code (code;tuple imports)))))
+ dependencies (monad;map @ (: (-> [Text Text] (Meta (IO (Future (Error Compiler)))))
+ (function [[dependency alias]]
+ (do @
+ [_ (&;assert Module-Cannot-Import-Itself current-module
+ (not (text/= current-module dependency)))
+ already-seen? (moduleL;exists? dependency)
+ circular-dependency? (if already-seen?
+ (moduleL;active? dependency)
+ (wrap false))
+ _ (&;assert Circular-Dependency (format "From: " current-module "\n"
+ " To: " dependency)
+ (not circular-dependency?))
+ _ (moduleL;import dependency)
+ _ (if (text/= "" alias)
+ (wrap [])
+ (moduleL;alias alias dependency))
+ compiler macro;get-compiler]
+ (if already-seen?
+ (wrap (io (CompletableFuture.completedFuture [(#e;Success compiler)])))
+ (wrap (translate-dependency translate-module dependency compiler))))))
+ imports)
+ compiler macro;get-compiler]
+ (wrap (do io;Monad<Process>
+ [dependencies (monad;seq io;Monad<Process> (list/map from-io dependencies))
+ dependencies (|> dependencies
+ (list/map (Future.get []))
+ (monad;seq io;Monad<Process>))]
+ (wrap (list/fold (merge-compilers current-module) compiler dependencies))))))
diff --git a/new-luxc/source/luxc/lang/translation/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/reference.jvm.lux
index 9d0cc91e4..bfc838041 100644
--- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux
@@ -25,7 +25,9 @@
(def: #export (translate-captured variable)
(-> Variable (Meta $;Inst))
(do macro;Monad<Meta>
- [function-class hostL;context]
+ [this-module macro;current-module-name
+ function-class hostL;context
+ #let [function-class (format (text;replace-all "/" "." this-module) "." function-class)]]
(wrap (|>. ($i;ALOAD +0)
($i;GETFIELD function-class
(|> variable i.inc (i.* -1) int-to-nat captured)
diff --git a/new-luxc/source/luxc/lang/translation/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/statement.jvm.lux
index 387181f98..df7e26741 100644
--- a/new-luxc/source/luxc/lang/translation/statement.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/statement.jvm.lux
@@ -36,48 +36,57 @@
(-> Text Type $;Inst $;Inst Code (Meta Unit))
(do macro;Monad<Meta>
[current-module macro;current-module-name
- #let [def-ident [current-module def-name]
- normal-name (format (&;normalize-name def-name) (%n (text/hash def-name)))
- bytecode-name (format current-module "/" normal-name)
- class-name (format current-module "." normal-name)
- bytecode ($d;class #$;V1.6
- #$;Public $;finalC
- bytecode-name
- (list) ["java.lang.Object" (list)]
- (list)
- (|>. ($d;field #$;Public ($;++F $;finalF $;staticF) commonT;value-field commonT;$Object)
- ($d;method #$;Public $;staticM "<clinit>" ($t;method (list) #;None (list))
- (|>. valueI
- ($i;PUTSTATIC bytecode-name commonT;value-field commonT;$Object)
- $i;RETURN))))]
- _ (commonT;store-class class-name bytecode)
- class (commonT;load-class class-name)
- valueV (: (Meta Top)
- (case (do e;Monad<Error>
- [field (Class.getField [commonT;value-field] class)]
- (Field.get [#;None] field))
- (#e;Success #;None)
- (&;throw Invalid-Definition-Value (%ident def-ident))
-
- (#e;Success (#;Some valueV))
- (wrap valueV)
-
- (#e;Error error)
- (&;throw Cannot-Evaluate-Definition
- (format "Definition: " (%ident def-ident) "\n"
- "Error:\n"
- error))))
- _ (&module;define def-ident [valueT metaV valueV])
- _ (if (macro;type? metaV)
- (case (macro;declared-tags metaV)
- #;Nil
- (wrap [])
+ #let [def-ident [current-module def-name]]]
+ (case (macro;get-symbol-ann (ident-for #;alias) metaV)
+ (#;Some real-def)
+ (do @
+ [[realT realA realV] (macro;find-def real-def)
+ _ (&module;define def-ident [realT metaV realV])]
+ (wrap []))
- tags
- (&module;declare-tags tags (macro;export? metaV) (:! Type valueV)))
- (wrap []))
- #let [_ (log! (format "DEF " (%ident def-ident)))]]
- (commonT;record-artifact (format bytecode-name ".class") bytecode)))
+ _
+ (do @
+ [#let [normal-name (format (&;normalize-name def-name) (%n (text/hash def-name)))
+ bytecode-name (format current-module "/" normal-name)
+ class-name (format (text;replace-all "/" "." current-module) "." normal-name)
+ bytecode ($d;class #$;V1.6
+ #$;Public $;finalC
+ bytecode-name
+ (list) ["java.lang.Object" (list)]
+ (list)
+ (|>. ($d;field #$;Public ($;++F $;finalF $;staticF) commonT;value-field commonT;$Object)
+ ($d;method #$;Public $;staticM "<clinit>" ($t;method (list) #;None (list))
+ (|>. valueI
+ ($i;PUTSTATIC bytecode-name commonT;value-field commonT;$Object)
+ $i;RETURN))))]
+ _ (commonT;store-class class-name bytecode)
+ class (commonT;load-class class-name)
+ valueV (: (Meta Top)
+ (case (do e;Monad<Error>
+ [field (Class.getField [commonT;value-field] class)]
+ (Field.get [#;None] field))
+ (#e;Success #;None)
+ (&;throw Invalid-Definition-Value (%ident def-ident))
+
+ (#e;Success (#;Some valueV))
+ (wrap valueV)
+
+ (#e;Error error)
+ (&;throw Cannot-Evaluate-Definition
+ (format "Definition: " (%ident def-ident) "\n"
+ "Error:\n"
+ error))))
+ _ (&module;define def-ident [valueT metaV valueV])
+ _ (if (macro;type? metaV)
+ (case (macro;declared-tags metaV)
+ #;Nil
+ (wrap [])
+
+ tags
+ (&module;declare-tags tags (macro;export? metaV) (:! Type valueV)))
+ (wrap []))
+ #let [_ (log! (format "DEF " (%ident def-ident)))]]
+ (commonT;record-artifact (format bytecode-name ".class") bytecode)))))
(def: #export (translate-program program-args programI)
(-> Text $;Inst (Meta Unit))
diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux
index bdf0758c3..848350499 100644
--- a/stdlib/source/lux/concurrency/actor.lux
+++ b/stdlib/source/lux/concurrency/actor.lux
@@ -152,8 +152,7 @@
(def: #hidden (<resolve> name)
(-> Ident (Meta Ident))
(do Monad<Meta>
- [name (macro;normalize name)
- [_ annotations _] (macro;find-def name)]
+ [[_ annotations _] (macro;find-def name)]
(case (macro;get-tag-ann (ident-for <tag>) annotations)
(#;Some actor-name)
(wrap actor-name)
diff --git a/stdlib/source/lux/concurrency/atom.lux b/stdlib/source/lux/concurrency/atom.lux
index 1260c758f..2837d6177 100644
--- a/stdlib/source/lux/concurrency/atom.lux
+++ b/stdlib/source/lux/concurrency/atom.lux
@@ -11,7 +11,7 @@
(All [a] (-> a (Atom a)))
("lux atom new" value))
-(def: #export (get atom)
+(def: #export (read atom)
(All [a] (-> (Atom a) (IO a)))
(io ("lux atom get" atom)))
@@ -34,6 +34,6 @@
[]
(io;run (update f atom))))))
-(def: #export (set value atom)
+(def: #export (write value atom)
(All [a] (-> a (Atom a) (IO Unit)))
(update (function;const value) atom))
diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux
index 115f60dc1..78cdbecce 100644
--- a/stdlib/source/lux/concurrency/promise.lux
+++ b/stdlib/source/lux/concurrency/promise.lux
@@ -40,7 +40,7 @@
(def: #export (poll promise)
{#;doc "Polls a Promise's value."}
(All [a] (-> (Promise a) (Maybe a)))
- (|> (atom;get promise)
+ (|> (atom;read promise)
io;run
(get@ #value)))
@@ -58,7 +58,7 @@
{#;doc "Sets an Promise's value if it has not been done yet."}
(All [a] (-> a (Promise a) (IO Bool)))
(do Monad<IO>
- [old (atom;get promise)]
+ [old (atom;read promise)]
(case (get@ #value old)
(#;Some _)
(wrap false)
@@ -76,7 +76,7 @@
(def: (await f promise)
(All [a] (-> (-> a (IO Unit)) (Promise a) Unit))
- (let [old (io;run (atom;get promise))]
+ (let [old (io;run (atom;read promise))]
(case (get@ #value old)
(#;Some value)
(io;run (f value))
diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux
index 7886dda36..1fee00b7e 100644
--- a/stdlib/source/lux/concurrency/stm.lux
+++ b/stdlib/source/lux/concurrency/stm.lux
@@ -1,23 +1,22 @@
(;module:
lux
- (lux (control ["F" functor]
- ["A" applicative]
- ["M" monad #+ do Monad])
+ (lux (control [functor #+ Functor]
+ [applicative #+ Applicative]
+ [monad #+ do Monad])
[io #- run]
- (data (coll [list "L/" Functor<List> Fold<List>]
- [dict #+ Dict]
- ["Q" queue])
+ (data (coll [list "list/" Functor<List> Fold<List>]
+ [dict #+ Dict])
[product]
[text]
maybe
- [number "Nat/" Codec<Text,Nat>]
+ [number "nat/" Codec<Text,Nat>]
text/format)
[macro]
(macro [code]
["s" syntax #+ syntax: Syntax])
(concurrency [atom #+ Atom atom]
["P" promise]
- [frp])
+ [frp "frp/" Functor<Channel>])
))
(type: (Var-State a)
@@ -48,7 +47,7 @@
(def: raw-read
(All [a] (-> (Var a) a))
- (|>. atom;get io;run (get@ #value)))
+ (|>. atom;read io;run (get@ #value)))
(def: (find-var-value var tx)
(All [a] (-> (Var a) Tx (Maybe a)))
@@ -76,7 +75,7 @@
{#;doc "Reads var immediately, without going through a transaction."}
(All [a] (-> (Var a) (IO a)))
(|> var
- atom;get
+ atom;read
(:: Functor<IO> map (get@ #value))))
(def: (update-tx-value var value tx)
@@ -112,7 +111,7 @@
{#;doc "Writes value to var immediately, without going through a transaction."}
(All [a] (-> a (Var a) (IO Unit)))
(do Monad<IO>
- [old (atom;get var)
+ [old (atom;read var)
#let [old-value (get@ #value old)
new (set@ #value new-value old)]
succeeded? (atom;compare-and-swap old new var)]
@@ -121,7 +120,7 @@
[_ (|> old
(get@ #observers)
dict;values
- (M;map @ (function [f] (f new-value))))]
+ (monad;map @ (function [f] (f new-value))))]
(wrap []))
(write! new-value var))))
@@ -143,26 +142,26 @@
(write! tail' channel-var)))]
(do Monad<IO>
[_ (atom;update (function [[value observers]]
- (let [label (Nat/encode (L/fold (function [key base]
- (case (Nat/decode key)
- (#;Left _)
- base
-
- (#;Right key-num)
- (n.max key-num base)))
- +0
- (dict;keys observers)))]
+ (let [label (nat/encode (list/fold (function [key base]
+ (case (nat/decode key)
+ (#;Left _)
+ base
+
+ (#;Right key-num)
+ (n.max key-num base)))
+ +0
+ (dict;keys observers)))]
[value (dict;put label (observer label) observers)]))
target)]
(wrap head))))
-(struct: #export _ (F;Functor STM)
+(struct: #export _ (Functor STM)
(def: (map f fa)
(function [tx]
(let [[tx' a] (fa tx)]
[tx' (f a)]))))
-(struct: #export _ (A;Applicative STM)
+(struct: #export _ (Applicative STM)
(def: functor Functor<STM>)
(def: (wrap a)
@@ -186,7 +185,7 @@
{#;doc "Will update a Var's value, and return a tuple with the old and the new values."}
(All [a] (-> (-> a a) (Var a) (IO [a a])))
(io (loop [_ []]
- (let [(^@ state [value observers]) (io;run (atom;get var))
+ (let [(^@ state [value observers]) (io;run (atom;read var))
value' (f value)]
(if (io;run (atom;compare-and-swap state
[value' observers]
@@ -225,31 +224,18 @@
(Atom Bool)
(atom false))
-(def: (process-commit commits)
- (-> (frp;Channel [(STM Unit) (P;Promise Unit)])
- (P;Promise Unit))
- (do P;Monad<Promise>
- [?head+tail commits]
- (case ?head+tail
- (#;Cons [stm-proc output] tail)
- (do @
- [#let [[finished-tx value] (stm-proc fresh-tx)]]
- (exec (if (can-commit? finished-tx)
- (exec (L/map commit-var finished-tx)
- (io;run (P;resolve value output))
- [])
- (exec (io;run (write! [stm-proc output] pending-commits))
- []))
- (process-commit tail)))
-
- #;Nil
- (undefined)
- )))
+(def: (process-commit [stm-proc output])
+ (-> [(STM Unit) (P;Promise Unit)] Top)
+ (let [[finished-tx value] (stm-proc fresh-tx)]
+ (if (can-commit? finished-tx)
+ (exec (list/map commit-var finished-tx)
+ (io;run (P;resolve value output)))
+ (io;run (write! [stm-proc output] pending-commits)))))
(def: init-processor!
(IO Unit)
(do Monad<IO>
- [flag (atom;get commit-processor-flag)]
+ [flag (atom;read commit-processor-flag)]
(if flag
(wrap [])
(do @
@@ -257,8 +243,9 @@
(if was-first?
(do Monad<IO>
[inputs (follow pending-commits)]
- (exec (process-commit (:! (frp;Channel [(STM Unit) (P;Promise Unit)])
- inputs))
+ (exec (|> inputs
+ (:! (frp;Channel [(STM Unit) (P;Promise Unit)]))
+ (frp/map process-commit))
(wrap [])))
(wrap [])))
)))
diff --git a/stdlib/source/lux/control/eq.lux b/stdlib/source/lux/control/eq.lux
index b69292daa..9e372bd58 100644
--- a/stdlib/source/lux/control/eq.lux
+++ b/stdlib/source/lux/control/eq.lux
@@ -5,13 +5,13 @@
(: (-> a a Bool)
=))
-(def: #export (seq left right)
+(def: #export (pair left right)
(All [l r] (-> (Eq l) (Eq r) (Eq [l r])))
(struct (def: (= [a b] [x y])
(and (:: left = a x)
(:: right = b y)))))
-(def: #export (alt left right)
+(def: #export (either left right)
(All [l r] (-> (Eq l) (Eq r) (Eq (| l r))))
(struct (def: (= a|b x|y)
(case [a|b x|y]
diff --git a/stdlib/source/lux/data/lazy.lux b/stdlib/source/lux/data/lazy.lux
index e344c6a0a..86fdde4a4 100644
--- a/stdlib/source/lux/data/lazy.lux
+++ b/stdlib/source/lux/data/lazy.lux
@@ -1,10 +1,10 @@
(;module:
lux
(lux [io]
- (control ["F" functor]
- ["A" applicative]
- monad)
- (concurrency ["a" atom])
+ (control [functor #+ Functor]
+ [applicative #+ Applicative]
+ [monad #+ Monad do])
+ (concurrency [atom])
[macro]
(macro ["s" syntax #+ syntax:])
(type opaque)))
@@ -14,15 +14,15 @@
(def: #hidden (freeze' generator)
(All [a] (-> (-> [] a) (Lazy a)))
- (let [cache (a;atom (: (Maybe ($ +0)) #;None))]
+ (let [cache (atom;atom (: (Maybe ($ +0)) #;None))]
(@opaque (function [_]
- (case (io;run (a;get cache))
+ (case (io;run (atom;read cache))
(#;Some value)
value
_
(let [value (generator [])]
- (exec (io;run (a;compare-and-swap _ (#;Some value) cache))
+ (exec (io;run (atom;compare-and-swap _ (#;Some value) cache))
value)))))))
(def: #export (thaw l-value)
@@ -34,11 +34,11 @@
[g!_ (macro;gensym "_")]
(wrap (list (` (freeze' (function [(~ g!_)] (~ expr))))))))
-(struct: #export _ (F;Functor Lazy)
+(struct: #export _ (Functor Lazy)
(def: (map f fa)
(freeze (f (thaw fa)))))
-(struct: #export _ (A;Applicative Lazy)
+(struct: #export _ (Applicative Lazy)
(def: functor Functor<Lazy>)
(def: (wrap a)
diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux
index 1298a56d1..12f6d7abf 100644
--- a/stdlib/source/lux/host.jvm.lux
+++ b/stdlib/source/lux/host.jvm.lux
@@ -1344,7 +1344,7 @@
))
(syntax: #export (object [#let [imports (class-imports *compiler*)]]
- [#let [class-vars (list)]]
+ [class-vars (s;tuple (p;some (type-param^ imports)))]
[super (p;default object-super-class
(super-class-decl^ imports class-vars))]
[interfaces (p;default (list)
diff --git a/stdlib/source/lux/lang/syntax.lux b/stdlib/source/lux/lang/syntax.lux
index 9fe4939a2..7bc8e8cca 100644
--- a/stdlib/source/lux/lang/syntax.lux
+++ b/stdlib/source/lux/lang/syntax.lux
@@ -613,7 +613,7 @@
(p;fail (Unrecognized-Input current-module))))
)))))
-(def: #export (parse current-module [where offset source])
+(def: #export (read current-module [where offset source])
(-> Text Source (e;Error [Source Code]))
(case (p;run [offset source] (ast current-module where))
(#e;Error error)
diff --git a/stdlib/source/lux/lang/type/check.lux b/stdlib/source/lux/lang/type/check.lux
index cbf31ac08..086866ddf 100644
--- a/stdlib/source/lux/lang/type/check.lux
+++ b/stdlib/source/lux/lang/type/check.lux
@@ -458,6 +458,16 @@
[Type Type] [Type Type]
(Check (List Assumption)))
(case [eFT aFT]
+ (^or [(#;UnivQ _ _) (#;Ex _)] [(#;UnivQ _ _) (#;Var _)])
+ (do Monad<Check>
+ [eFT' (apply-type! eFT eAT)]
+ (check' eFT' (#;Apply aAT aFT) assumptions))
+
+ (^or [(#;Ex _) (#;UnivQ _ _)] [(#;Var _) (#;UnivQ _ _)])
+ (do Monad<Check>
+ [aFT' (apply-type! aFT aAT)]
+ (check' (#;Apply eAT eFT) aFT' assumptions))
+
(^or [(#;Ex _) _] [_ (#;Ex _)])
(do Monad<Check>
[assumptions (check' eFT aFT assumptions)]
diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux
index e65e09b58..e3cba7a31 100644
--- a/stdlib/source/lux/macro.lux
+++ b/stdlib/source/lux/macro.lux
@@ -1,8 +1,8 @@
(;module: {#;doc "Functions for extracting information from the state of the compiler."}
lux
- (lux (control ["F" functor]
- ["A" applicative]
- ["M" monad #+ do Monad])
+ (lux (control [functor #+ Functor]
+ [applicative #+ Applicative]
+ [monad #+ do Monad])
(data [number]
[product]
[ident "ident/" Codec<Text,Ident> Eq<Ident>]
@@ -15,30 +15,30 @@
## (type: (Meta a)
## (-> Compiler (e;Error [Compiler a])))
-(struct: #export _ (F;Functor Meta)
+(struct: #export _ (Functor Meta)
(def: (map f fa)
- (function [state]
- (case (fa state)
+ (function [compiler]
+ (case (fa compiler)
(#e;Error msg)
(#e;Error msg)
- (#e;Success [state' a])
- (#e;Success [state' (f a)])))))
+ (#e;Success [compiler' a])
+ (#e;Success [compiler' (f a)])))))
-(struct: #export _ (A;Applicative Meta)
+(struct: #export _ (Applicative Meta)
(def: functor Functor<Meta>)
(def: (wrap x)
- (function [state]
- (#e;Success [state x])))
+ (function [compiler]
+ (#e;Success [compiler x])))
(def: (apply ff fa)
- (function [state]
- (case (ff state)
- (#e;Success [state' f])
- (case (fa state')
- (#e;Success [state'' a])
- (#e;Success [state'' (f a)])
+ (function [compiler]
+ (case (ff compiler)
+ (#e;Success [compiler' f])
+ (case (fa compiler')
+ (#e;Success [compiler'' a])
+ (#e;Success [compiler'' (f a)])
(#e;Error msg)
(#e;Error msg))
@@ -50,13 +50,13 @@
(def: applicative Applicative<Meta>)
(def: (join mma)
- (function [state]
- (case (mma state)
+ (function [compiler]
+ (case (mma compiler)
(#e;Error msg)
(#e;Error msg)
- (#e;Success [state' ma])
- (ma state')))))
+ (#e;Success [compiler' ma])
+ (ma compiler')))))
(def: (get k plist)
(All [a]
@@ -111,20 +111,20 @@
(def: #export (find-module name)
(-> Text (Meta Module))
- (function [state]
- (case (get name (get@ #;modules state))
+ (function [compiler]
+ (case (get name (get@ #;modules compiler))
(#;Some module)
- (#e;Success [state module])
+ (#e;Success [compiler module])
_
(#e;Error ($_ text/compose "Unknown module: " name)))))
(def: #export current-module-name
(Meta Text)
- (function [state]
- (case (get@ #;current-module state)
+ (function [compiler]
+ (case (get@ #;current-module compiler)
(#;Some current-module)
- (#e;Success [state current-module])
+ (#e;Success [compiler current-module])
_
(#e;Error "No current module.")
@@ -183,7 +183,7 @@
(def: #export (get-doc anns)
{#;doc "Looks-up a definition's documentation."}
(-> Code (Maybe Text))
- (get-text-ann ["lux" "doc"] anns))
+ (get-text-ann (ident-for #;doc) anns))
(def: #export (flag-set? flag-name anns)
{#;doc "Finds out whether an annotation-as-a-flag is set (has value 'true')."}
@@ -205,6 +205,15 @@
[sig? #;sig? "a signature"]
)
+(def: #export (aliased? annotations)
+ (-> Code Bool)
+ (case (get-symbol-ann (ident-for #;alias) annotations)
+ (#;Some _)
+ true
+
+ #;None
+ false))
+
(do-template [<name> <tag> <type>]
[(def: (<name> input)
(-> Code (Maybe <type>))
@@ -227,7 +236,7 @@
(do maybe;Monad<Maybe>
[_args (get-ann (ident-for <tag>) anns)
args (parse-tuple _args)]
- (M;map @ parse-text args))))]
+ (monad;map @ parse-text args))))]
[func-args #;func-args "Looks up the arguments of a function."]
[type-args #;type-args "Looks up the arguments of a parameterized type."]
@@ -243,22 +252,13 @@
(if (and (macro? def-anns)
(or (export? def-anns) (text/= module this-module)))
(#;Some (:! Macro def-value))
- (case (get-symbol-ann ["lux" "alias"] def-anns)
+ (case (get-symbol-ann (ident-for #;alias) def-anns)
(#;Some [r-module r-name])
(find-macro' modules this-module r-module r-name)
_
#;None))))
-(def: #export (find-macro ident)
- (-> Ident (Meta (Maybe Macro)))
- (do Monad<Meta>
- [this-module current-module-name]
- (let [[module name] ident]
- (: (Meta (Maybe Macro))
- (function [state]
- (#e;Success [state (find-macro' (get@ #;modules state) this-module module name)]))))))
-
(def: #export (normalize ident)
{#;doc "If given an identifier without a module prefix, gives it the current module's name as prefix.
@@ -273,6 +273,16 @@
_
(:: Monad<Meta> wrap ident)))
+(def: #export (find-macro ident)
+ (-> Ident (Meta (Maybe Macro)))
+ (do Monad<Meta>
+ [ident (normalize ident)
+ this-module current-module-name]
+ (let [[module name] ident]
+ (: (Meta (Maybe Macro))
+ (function [compiler]
+ (#e;Success [compiler (find-macro' (get@ #;modules compiler) this-module module name)]))))))
+
(def: #export (expand-once syntax)
{#;doc "Given code that requires applying a macro, does it once and returns the result.
@@ -281,8 +291,7 @@
(case syntax
[_ (#;Form (#;Cons [[_ (#;Symbol name)] args]))]
(do Monad<Meta>
- [name' (normalize name)
- ?macro (find-macro name')]
+ [?macro (find-macro name)]
(case ?macro
(#;Some macro)
(macro args)
@@ -301,13 +310,12 @@
(case syntax
[_ (#;Form (#;Cons [[_ (#;Symbol name)] args]))]
(do Monad<Meta>
- [name' (normalize name)
- ?macro (find-macro name')]
+ [?macro (find-macro name)]
(case ?macro
(#;Some macro)
(do Monad<Meta>
[expansion (macro args)
- expansion' (M;map Monad<Meta> expand expansion)]
+ expansion' (monad;map Monad<Meta> expand expansion)]
(wrap (list/join expansion')))
#;None
@@ -322,29 +330,28 @@
(case syntax
[_ (#;Form (#;Cons [[_ (#;Symbol name)] args]))]
(do Monad<Meta>
- [name' (normalize name)
- ?macro (find-macro name')]
+ [?macro (find-macro name)]
(case ?macro
(#;Some macro)
(do Monad<Meta>
[expansion (macro args)
- expansion' (M;map Monad<Meta> expand-all expansion)]
+ expansion' (monad;map Monad<Meta> expand-all expansion)]
(wrap (list/join expansion')))
#;None
(do Monad<Meta>
- [parts' (M;map Monad<Meta> expand-all (list& (code;symbol name) args))]
+ [parts' (monad;map Monad<Meta> expand-all (list& (code;symbol name) args))]
(wrap (list (code;form (list/join parts')))))))
[_ (#;Form (#;Cons [harg targs]))]
(do Monad<Meta>
[harg+ (expand-all harg)
- targs+ (M;map Monad<Meta> expand-all targs)]
+ targs+ (monad;map Monad<Meta> expand-all targs)]
(wrap (list (code;form (list/compose harg+ (list/join (: (List (List Code)) targs+)))))))
[_ (#;Tuple members)]
(do Monad<Meta>
- [members' (M;map Monad<Meta> expand-all members)]
+ [members' (monad;map Monad<Meta> expand-all members)]
(wrap (list (code;tuple (list/join members')))))
_
@@ -355,9 +362,9 @@
A prefix can be given (or just be empty text \"\") to better identify the code for debugging purposes."}
(-> Text (Meta Code))
- (function [state]
- (#e;Success [(update@ #;seed n.inc state)
- (code;symbol ["" ($_ text/compose "__gensym__" prefix (:: number;Codec<Text,Nat> encode (get@ #;seed state)))])])))
+ (function [compiler]
+ (#e;Success [(update@ #;seed n.inc compiler)
+ (code;symbol ["" ($_ text/compose "__gensym__" prefix (:: number;Codec<Text,Nat> encode (get@ #;seed compiler)))])])))
(def: (get-local-symbol ast)
(-> Code (Meta Text))
@@ -381,7 +388,7 @@
(case tokens
(^ (list [_ (#;Tuple symbols)] body))
(do Monad<Meta>
- [symbol-names (M;map @ get-local-symbol symbols)
+ [symbol-names (monad;map @ get-local-symbol symbols)
#let [symbol-defs (list/join (list/map (: (-> Text (List Code))
(function [name] (list (code;symbol ["" name]) (` (gensym (~ (code;text name)))))))
symbol-names))]]
@@ -406,13 +413,13 @@
(def: #export (module-exists? module)
(-> Text (Meta Bool))
- (function [state]
- (#e;Success [state (case (get module (get@ #;modules state))
- (#;Some _)
- true
-
- #;None
- false)])))
+ (function [compiler]
+ (#e;Success [compiler (case (get module (get@ #;modules compiler))
+ (#;Some _)
+ true
+
+ #;None
+ false)])))
(def: (try-both f x1 x2)
(All [a b]
@@ -424,7 +431,7 @@
(def: #export (find-var-type name)
{#;doc "Looks-up the type of a local variable somewhere in the environment."}
(-> Text (Meta Type))
- (function [state]
+ (function [compiler]
(let [test (: (-> [Text [Type Top]] Bool)
(|>. product;left (text/= name)))]
(case (do maybe;Monad<Maybe>
@@ -433,7 +440,7 @@
(get@ [#;locals #;mappings] env)))
(list;any? test (: (List [Text [Type Top]])
(get@ [#;captured #;mappings] env)))))
- (get@ #;scopes state))
+ (get@ #;scopes compiler))
[_ [type _]] (try-both (list;find test)
(: (List [Text [Type Top]])
(get@ [#;locals #;mappings] scope))
@@ -441,25 +448,60 @@
(get@ [#;captured #;mappings] scope)))]
(wrap type))
(#;Some var-type)
- (#e;Success [state var-type])
+ (#e;Success [compiler var-type])
#;None
(#e;Error ($_ text/compose "Unknown variable: " name))))))
+(def: #export (canonical name)
+ (-> Ident (Meta Ident))
+ (case name
+ ["" _name]
+ (do Monad<Meta>
+ [this-module current-module-name]
+ (wrap [this-module _name]))
+
+ [_module _name]
+ (do Monad<Meta>
+ [this-module-name current-module-name
+ this-module (find-module this-module-name)]
+ (case (list;find (|>. product;left (text/= _module))
+ (get@ #;module-aliases this-module))
+ (#;Some [alias real])
+ (wrap [real _name])
+
+ _
+ (wrap name)))
+ ))
+
(def: #export (find-def name)
{#;doc "Looks-up a definition's whole data in the available modules (including the current one)."}
(-> Ident (Meta Def))
- (function [state]
- (case (: (Maybe Def)
- (do maybe;Monad<Maybe>
- [#let [[v-prefix v-name] name]
- (^slots [#;defs]) (get v-prefix (get@ #;modules state))]
- (get v-name defs)))
- (#;Some _anns)
- (#e;Success [state _anns])
+ (do Monad<Meta>
+ [name (canonical name)]
+ (function [compiler]
+ (case (: (Maybe Def)
+ (do maybe;Monad<Maybe>
+ [#let [[v-prefix v-name] name]
+ (^slots [#;defs]) (get v-prefix (get@ #;modules compiler))]
+ (get v-name defs)))
+ (#;Some definition)
+ (#e;Success [compiler definition])
- _
- (#e;Error ($_ text/compose "Unknown definition: " (ident/encode name))))))
+ _
+ (let [current-module (|> compiler (get@ #;current-module) (maybe;default "???"))]
+ (#e;Error ($_ text/compose
+ "Unknown definition: " (ident/encode name) "\n"
+ " Current module: " current-module "\n"
+ (case (get current-module (get@ #;modules compiler))
+ (#;Some this-module)
+ ($_ text/compose
+ " Imports: " (|> this-module (get@ #;imports) (text;join-with ", ")) "\n"
+ " Aliases: " (|> this-module (get@ #;module-aliases) (list/map (function [[alias real]] ($_ text/compose alias " => " real))) (text;join-with ", ")) "\n")
+
+ _
+ "")
+ " All Known modules: " (|> compiler (get@ #;modules) (list/map product;left) (text;join-with ", ")) "\n")))))))
(def: #export (find-def-type name)
{#;doc "Looks-up a definition's type in the available modules (including the current one)."}
@@ -473,10 +515,13 @@
(-> Ident (Meta Type))
(do Monad<Meta>
[#let [[_ _name] name]]
- (either (find-var-type _name)
- (do @
- [name (normalize name)]
- (find-def-type name)))))
+ (case name
+ ["" _name]
+ (either (find-var-type _name)
+ (find-def-type name))
+
+ _
+ (find-def-type name))))
(def: #export (find-type-def name)
{#;doc "Finds the value of a type definition (such as Int, Top or Compiler)."}
@@ -488,10 +533,10 @@
(def: #export (defs module-name)
{#;doc "The entire list of definitions in a module (including the unexported/private ones)."}
(-> Text (Meta (List [Text Def])))
- (function [state]
- (case (get module-name (get@ #;modules state))
+ (function [compiler]
+ (case (get module-name (get@ #;modules compiler))
#;None (#e;Error ($_ text/compose "Unknown module: " module-name))
- (#;Some module) (#e;Success [state (get@ #;defs module)])
+ (#;Some module) (#e;Success [compiler (get@ #;defs module)])
)))
(def: #export (exports module-name)
@@ -507,10 +552,10 @@
(def: #export modules
{#;doc "All the available modules (including the current one)."}
(Meta (List [Text Module]))
- (function [state]
- (|> state
+ (function [compiler]
+ (|> compiler
(get@ #;modules)
- [state]
+ [compiler]
#e;Success)))
(def: #export (tags-of type-name)
@@ -529,16 +574,16 @@
(def: #export cursor
{#;doc "The cursor of the current expression being analyzed."}
(Meta Cursor)
- (function [state]
- (#e;Success [state (get@ #;cursor state)])))
+ (function [compiler]
+ (#e;Success [compiler (get@ #;cursor compiler)])))
(def: #export expected-type
{#;doc "The expected type of the current expression being analyzed."}
(Meta Type)
- (function [state]
- (case (get@ #;expected state)
+ (function [compiler]
+ (case (get@ #;expected compiler)
(#;Some type)
- (#e;Success [state type])
+ (#e;Success [compiler type])
#;None
(#e;Error "Not expecting any type."))))
@@ -583,13 +628,13 @@
(def: #export locals
{#;doc "All the local variables currently in scope, separated in different scopes."}
(Meta (List (List [Text Type])))
- (function [state]
- (case (list;inits (get@ #;scopes state))
+ (function [compiler]
+ (case (list;inits (get@ #;scopes compiler))
#;None
(#e;Error "No local environment")
(#;Some scopes)
- (#e;Success [state
+ (#e;Success [compiler
(list/map (|>. (get@ [#;locals #;mappings])
(list/map (function [[name [type _]]]
[name type])))
@@ -599,8 +644,7 @@
{#;doc "Given an aliased definition's name, returns the original definition being referenced."}
(-> Ident (Meta Ident))
(do Monad<Meta>
- [def-name (normalize def-name)
- [_ def-anns _] (find-def def-name)]
+ [[_ def-anns _] (find-def def-name)]
(case (get-symbol-ann (ident-for #;alias) def-anns)
(#;Some real-def-name)
(wrap real-def-name)
diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux
index d296a9a2e..f8cfa9871 100644
--- a/stdlib/source/lux/test.lux
+++ b/stdlib/source/lux/test.lux
@@ -1,6 +1,6 @@
(;module: {#;doc "Tools for unit & property-based/generative testing."}
lux
- (lux [macro #+ Monad<Meta> with-gensyms]
+ (lux [macro #+ with-gensyms]
(macro ["s" syntax #+ syntax: Syntax]
[code])
(control [monad #+ do Monad]
@@ -12,7 +12,7 @@
[text]
text/format
["e" error])
- [io #- run]
+ [io #+ IO io]
(time [instant]
[duration])
["r" math/random]))
@@ -199,7 +199,7 @@
(def: (exported-tests module-name)
(-> Text (Meta (List [Text Text Text])))
- (do Monad<Meta>
+ (do macro;Monad<Meta>
[defs (macro;exports module-name)]
(wrap (|> defs
(list/map (function [[def-name [_ def-anns _]]]
diff --git a/stdlib/source/lux/type/object.lux b/stdlib/source/lux/type/object.lux
index fc68dcdae..a7945b41a 100644
--- a/stdlib/source/lux/type/object.lux
+++ b/stdlib/source/lux/type/object.lux
@@ -143,8 +143,7 @@
[(def: (<name> name)
(-> Ident (Meta [Ident (List Ident)]))
(do Monad<Meta>
- [name (macro;normalize name)
- [_ annotations _] (macro;find-def name)]
+ [[_ annotations _] (macro;find-def name)]
(case [(macro;get-tag-ann (ident-for <name-tag>) annotations)
(macro;get-tag-ann (ident-for <parent-tag>) annotations)]
[(#;Some real-name) (#;Some parent)]
diff --git a/stdlib/test/test/lux/concurrency/atom.lux b/stdlib/test/test/lux/concurrency/atom.lux
index 90c1c07d2..039546436 100644
--- a/stdlib/test/test/lux/concurrency/atom.lux
+++ b/stdlib/test/test/lux/concurrency/atom.lux
@@ -18,17 +18,17 @@
#let [box (&;atom value)]]
($_ seq
(test "Can obtain the value of an atom."
- (n.= value (io;run (&;get box))))
+ (n.= value (io;run (&;read box))))
(test "Can swap the value of an atom."
(and (io;run (&;compare-and-swap value swap-value box))
- (n.= swap-value (io;run (&;get box)))))
+ (n.= swap-value (io;run (&;read box)))))
(test "Can update the value of an atom."
(exec (io;run (&;update n.inc box))
- (n.= (n.inc swap-value) (io;run (&;get box)))))
+ (n.= (n.inc swap-value) (io;run (&;read box)))))
(test "Can immediately set the value of an atom."
- (exec (io;run (&;set set-value box))
- (n.= set-value (io;run (&;get box)))))
+ (exec (io;run (&;write set-value box))
+ (n.= set-value (io;run (&;read box)))))
))))
diff --git a/stdlib/test/test/lux/data/coll/dict.lux b/stdlib/test/test/lux/data/coll/dict.lux
index f2e47615a..536ad8450 100644
--- a/stdlib/test/test/lux/data/coll/dict.lux
+++ b/stdlib/test/test/lux/data/coll/dict.lux
@@ -8,7 +8,7 @@
[number]
[maybe]
(coll ["&" dict]
- [list "L/" Fold<List> Functor<List>]))
+ [list "list/" Fold<List> Functor<List>]))
["r" math/random])
lux/test)
@@ -30,7 +30,7 @@
(not (&;empty? dict))))
(test "The functions 'entries', 'keys' and 'values' should be synchronized."
- (:: (list;Eq<List> (eq;seq number;Eq<Nat> number;Eq<Nat>)) =
+ (:: (list;Eq<List> (eq;pair number;Eq<Nat> number;Eq<Nat>)) =
(&;entries dict)
(list;zip2 (&;keys dict)
(&;values dict))))
@@ -99,7 +99,7 @@
(test "If you merge, and the second dict has overlapping keys, it should overwrite yours."
(let [dict' (|> dict &;entries
- (L/map (function [[k v]] [k (n.inc v)]))
+ (list/map (function [[k v]] [k (n.inc v)]))
(&;from-list number;Hash<Nat>))
(^open) (&;Eq<Dict> number;Eq<Nat>)]
(= dict' (&;merge dict' dict))))
diff --git a/stdlib/test/test/lux/host.jvm.lux b/stdlib/test/test/lux/host.jvm.lux
index d41c587c8..070457799 100644
--- a/stdlib/test/test/lux/host.jvm.lux
+++ b/stdlib/test/test/lux/host.jvm.lux
@@ -11,6 +11,8 @@
["r" math/random])
lux/test)
+(&;import (java.util.concurrent.Callable a))
+
(&;import java.lang.Exception
(new [String]))
@@ -44,11 +46,17 @@
)
(def: test-runnable
- (object [Runnable]
+ (object [] [Runnable]
[]
(Runnable [] (run) void
[])))
+(def: test-callable
+ (object [a] [(Callable a)]
+ []
+ (Callable [] (call) a
+ (undefined))))
+
(interface: TestInterface
([] foo [boolean String] void #throws [Exception]))
diff --git a/stdlib/test/test/lux/lang/syntax.lux b/stdlib/test/test/lux/lang/syntax.lux
index 154e18a91..3eb9bfc02 100644
--- a/stdlib/test/test/lux/lang/syntax.lux
+++ b/stdlib/test/test/lux/lang/syntax.lux
@@ -80,20 +80,20 @@
other code^]
($_ seq
(test "Can parse Lux code."
- (case (&;parse "" [default-cursor +0 (code;to-text sample)])
+ (case (&;read "" [default-cursor +0 (code;to-text sample)])
(#e;Error error)
false
(#e;Success [_ parsed])
(:: code;Eq<Code> = parsed sample)))
(test "Can parse Lux multiple code nodes."
- (case (&;parse "" [default-cursor +0 (format (code;to-text sample) " "
- (code;to-text other))])
+ (case (&;read "" [default-cursor +0 (format (code;to-text sample) " "
+ (code;to-text other))])
(#e;Error error)
false
(#e;Success [remaining =sample])
- (case (&;parse "" remaining)
+ (case (&;read "" remaining)
(#e;Error error)
false
@@ -114,11 +114,11 @@
signed? r;bool
#let [expected (|> numerator (f./ denominator) (f.* (if signed? -1.0 1.0)))]]
(test "Can parse frac ratio syntax."
- (case (&;parse "" [default-cursor +0
- (format (if signed? "-" "")
- (%i (frac-to-int numerator))
- "/"
- (%i (frac-to-int denominator)))])
+ (case (&;read "" [default-cursor +0
+ (format (if signed? "-" "")
+ (%i (frac-to-int numerator))
+ "/"
+ (%i (frac-to-int denominator)))])
(#e;Success [_ [_ (#;Frac actual)]])
(f.= expected actual)
@@ -131,8 +131,8 @@
(do @
[expected (|> r;nat (:: @ map (n.% +1_000)))]
(test "Can parse nat char syntax."
- (case (&;parse "" [default-cursor +0
- (format "#" (%t (text;from-code expected)) "")])
+ (case (&;read "" [default-cursor +0
+ (format "#" (%t (text;from-code expected)) "")])
(#e;Success [_ [_ (#;Nat actual)]])
(n.= expected actual)
@@ -181,8 +181,8 @@
(let [bad-match (format (text;from-code x) "\n"
(text;from-code y) "\n"
(text;from-code z))]
- (case (&;parse "" [default-cursor +0
- (format "\"" bad-match "\"")])
+ (case (&;read "" [default-cursor +0
+ (format "\"" bad-match "\"")])
(#e;Error error)
true
@@ -195,9 +195,9 @@
good-output (format (text;from-code x) "\n"
(text;from-code y) "\n"
(text;from-code z))]
- (case (&;parse "" [(|> default-cursor (update@ #;column (n.+ (n.dec offset-size))))
- +0
- (format "\"" good-input "\"")])
+ (case (&;read "" [(|> default-cursor (update@ #;column (n.+ (n.dec offset-size))))
+ +0
+ (format "\"" good-input "\"")])
(#e;Error error)
false
@@ -206,25 +206,25 @@
parsed
(code;text good-output)))))
(test "Can handle comments."
- (case (&;parse "" [default-cursor +0
- (format comment (code;to-text sample))])
+ (case (&;read "" [default-cursor +0
+ (format comment (code;to-text sample))])
(#e;Error error)
false
(#e;Success [_ parsed])
(:: code;Eq<Code> = parsed sample)))
(test "Will reject unbalanced multi-line comments."
- (and (case (&;parse "" [default-cursor +0
- (format "#(" "#(" unbalanced-comment ")#"
- (code;to-text sample))])
+ (and (case (&;read "" [default-cursor +0
+ (format "#(" "#(" unbalanced-comment ")#"
+ (code;to-text sample))])
(#e;Error error)
true
(#e;Success [_ parsed])
false)
- (case (&;parse "" [default-cursor +0
- (format "#(" unbalanced-comment ")#" ")#"
- (code;to-text sample))])
+ (case (&;read "" [default-cursor +0
+ (format "#(" unbalanced-comment ")#" ")#"
+ (code;to-text sample))])
(#e;Error error)
true