diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/io.jvm.lux | 73 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang.lux | 12 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/case.lux | 2 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/expression.lux | 28 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/reference.lux | 13 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/structure.lux | 32 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/host.jvm.lux | 8 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/module.lux | 72 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation.lux | 160 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/common.jvm.lux | 10 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/eval.jvm.lux | 15 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/function.jvm.lux | 2 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/imports.jvm.lux | 150 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/reference.jvm.lux | 4 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/statement.jvm.lux | 91 |
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)) |