aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source
diff options
context:
space:
mode:
Diffstat (limited to '')
-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
15 files changed, 494 insertions, 178 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))