aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc')
-rw-r--r--new-luxc/source/luxc/cache.lux9
-rw-r--r--new-luxc/source/luxc/cache/description.lux147
-rw-r--r--new-luxc/source/luxc/cache/influences.lux27
-rw-r--r--new-luxc/source/luxc/cache/io.lux210
-rw-r--r--new-luxc/source/luxc/io.jvm.lux42
-rw-r--r--new-luxc/source/luxc/lang/host.jvm.lux4
-rw-r--r--new-luxc/source/luxc/lang/host/jvm/def.lux10
-rw-r--r--new-luxc/source/luxc/lang/host/jvm/inst.lux4
-rw-r--r--new-luxc/source/luxc/lang/translation.lux50
-rw-r--r--new-luxc/source/luxc/lang/translation/common.jvm.lux62
-rw-r--r--new-luxc/source/luxc/module/descriptor/annotation.lux81
-rw-r--r--new-luxc/source/luxc/module/descriptor/common.lux37
-rw-r--r--new-luxc/source/luxc/module/descriptor/type.lux145
13 files changed, 513 insertions, 315 deletions
diff --git a/new-luxc/source/luxc/cache.lux b/new-luxc/source/luxc/cache.lux
new file mode 100644
index 000000000..2b47c12dc
--- /dev/null
+++ b/new-luxc/source/luxc/cache.lux
@@ -0,0 +1,9 @@
+(.module:
+ lux
+ (lux (data [text]
+ (coll [dict #+ Dict]))))
+
+(type: #export Cache (Dict Text Module))
+(def: #export empty Cache (dict.new text.Hash<Text>))
+
+(def: #export descriptor-name Text "lux_module_descriptor")
diff --git a/new-luxc/source/luxc/cache/description.lux b/new-luxc/source/luxc/cache/description.lux
new file mode 100644
index 000000000..1bfb1209c
--- /dev/null
+++ b/new-luxc/source/luxc/cache/description.lux
@@ -0,0 +1,147 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["p" parser "parser/" Monad<Parser>]
+ ["ex" exception #+ exception:])
+ (data [product]
+ ["e" error #+ Error]
+ [text "text/" Eq<Text>]
+ text/format
+ (coll [list "list/" Functor<List>]))
+ (macro [code]
+ ["s" syntax #+ Syntax]))
+ [///lang])
+
+(exception: #export Invalid-Lux-Version)
+
+(def: (write-type type)
+ (-> Type Code)
+ (case type
+ (#.Primitive name params)
+ (` ("Primitive"
+ (~ (code.text name))
+ (~+ (list/map write-type params))))
+
+ #.Void
+ (` "Void")
+
+ #.Unit
+ (` "Unit")
+
+ (^template [<tag> <description>]
+ (<tag> left right)
+ (` (<description> (~ (write-type left)) (~ (write-type right)))))
+ ([#.Sum "Sum"]
+ [#.Product "Product"]
+ [#.Function "Function"]
+ [#.Apply "Apply"])
+
+ (^template [<tag> <description>]
+ (<tag> id)
+ (` (<description> (~ (code.nat id)))))
+ ([#.Bound "Bound"]
+ [#.Var "Var"]
+ [#.Ex "Ex"])
+
+ (^template [<tag> <description>]
+ (<tag> env body)
+ (` (<description> (~ (code.tuple (list/map write-type env)))
+ (~ (write-type body)))))
+ ([#.UnivQ "UnivQ"]
+ [#.ExQ "ExQ"])
+
+ (#.Named name anonymous)
+ (` ("Named" (~ (code.symbol name)) (~ (write-type anonymous))))))
+
+(def: read-type
+ (Syntax Type)
+ (let [tagged (: (All [a] (-> Text (Syntax a) (Syntax a)))
+ (function [tag syntax]
+ (s.form (p.after (s.this (code.text tag)) syntax))))
+ binary (: (-> Text (Syntax Type) (Syntax [Type Type]))
+ (function [tag read-type]
+ (tagged tag (p.seq read-type read-type))))
+ indexed (: (-> Text (Syntax Nat))
+ (function [tag]
+ (tagged tag s.nat)))
+ quantified (: (-> Text (Syntax Type) (Syntax [(List Type) Type]))
+ (function [tag read-type]
+ (tagged tag (p.seq (s.tuple (p.some read-type))
+ read-type))))]
+ (p.rec
+ (function [read-type]
+ ($_ p.alt
+ (tagged "Primitive" (p.seq s.text (p.some read-type)))
+ (s.this (` "Void"))
+ (s.this (` "Unit"))
+ (binary "Sum" read-type)
+ (binary "Product" read-type)
+ (binary "Function" read-type)
+ (indexed "Bound")
+ (indexed "Var")
+ (indexed "Ex")
+ (quantified "UnivQ" read-type)
+ (quantified "ExQ" read-type)
+ (binary "Apply" read-type)
+ (tagged "Named" (p.seq s.symbol read-type))
+ )))))
+
+(def: (write-definition [type annotations value])
+ (-> Definition Code)
+ (` {"type" (~ (write-type type))
+ "annotations" (~ annotations)}))
+
+(def: read-definition
+ (Syntax Definition)
+ (s.record ($_ p.seq
+ (p.after (s.this (` "type")) read-type)
+ (p.after (s.this (` "annotations")) s.any)
+ (parser/wrap []))))
+
+(def: (write-aliases aliases)
+ (-> (List [Text Text]) Code)
+ (|> aliases (list/map (product.both code.text code.text)) code.record))
+
+(def: read-aliases
+ (Syntax (List [Text Text]))
+ (s.record (p.some (p.seq s.text s.text))))
+
+(def: #export (write lux-file module)
+ (-> Text Module Code)
+ (` {"lux version" (~ (code.text ///lang.version))
+ "lux file" (~ (code.text lux-file))
+ "hash" (~ (code.nat (get@ #.module-hash module)))
+ "aliases" (~ (write-aliases (get@ #.module-aliases module)))
+ "definitions" (~ (code.record (list/map (product.both code.text write-definition)
+ (get@ #.definitions module))))
+ "imports" (~ (code.tuple (list/map code.text (get@ #.imports module))))
+ "annotations" (~ (case (get@ #.module-annotations module)
+ #.None
+ (' "None")
+
+ (#.Some annotations)
+ (` ("Some" (~ annotations)))))
+ }))
+
+(def: #export (read description)
+ (-> Code (Error [Text Module]))
+ (<| (s.run (list description))
+ (s.record (do p.Monad<Parser>
+ [lux-version (p.after (s.this (` "lux version")) s.text)
+ _ (p.assert (Invalid-Lux-Version
+ (format "Expected: " ///lang.version "\n"
+ " Actual: " lux-version "\n"))
+ (text/= ///lang.version lux-version))]
+ ($_ p.seq
+ (p.after (s.this (` "lux file")) s.text)
+ ($_ p.seq
+ (p.after (s.this (` "hash")) s.nat)
+ (p.after (s.this (` "aliases")) read-aliases)
+ (p.after (s.this (` "definitions")) (s.record (p.some (p.seq s.text read-definition))))
+ (p.after (s.this (` "imports")) (s.tuple (p.some s.text)))
+ (parser/wrap (list))
+ (parser/wrap (list))
+ (p.after (s.this (` "annotations")) (p.alt (s.this (` "None"))
+ (s.form (p.after (s.this (` "Some"))
+ s.any))))
+ (parser/wrap #.Cached)))))))
diff --git a/new-luxc/source/luxc/cache/influences.lux b/new-luxc/source/luxc/cache/influences.lux
new file mode 100644
index 000000000..a75e1a7a1
--- /dev/null
+++ b/new-luxc/source/luxc/cache/influences.lux
@@ -0,0 +1,27 @@
+(.module:
+ lux
+ (lux (data [text]
+ (coll [list "list/" Fold<List>]
+ [dict #+ Dict]))))
+
+(type: #export Influences (Dict Text (List Text)))
+
+(def: #export (track to from)
+ (-> Text Text Influences Influences)
+ (|>> (dict.update~ from (list) (|>> (#.Cons to)))
+ (dict.update~ to (list) id)))
+
+(def: (effluents module influences)
+ (-> Text Influences (Maybe (List Text)))
+ (dict.get module influences))
+
+(def: #export (untrack module influences)
+ (-> Text Influences Influences)
+ (case (effluents module influences)
+ (#.Some effluents)
+ (list/fold untrack (dict.remove module influences) effluents)
+
+ #.None
+ influences))
+
+(def: #export empty Influences (dict.new text.Hash<Text>))
diff --git a/new-luxc/source/luxc/cache/io.lux b/new-luxc/source/luxc/cache/io.lux
new file mode 100644
index 000000000..9f5474c76
--- /dev/null
+++ b/new-luxc/source/luxc/cache/io.lux
@@ -0,0 +1,210 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data [product]
+ [maybe]
+ ["e" error #+ Error]
+ [bool "bool/" Eq<Bool>]
+ [text "text/" Hash<Text>]
+ text/format
+ (coll [list "list/" Fold<List>]
+ [dict #+ Dict]
+ [set #+ Set]))
+ (lang [syntax #+ Aliases])
+ [io #+ Process "process/" Monad<Process>]
+ (concurrency [atom #+ Atom atom])
+ (world [file #+ File]
+ [blob #+ Blob]))
+ [///io]
+ [//description]
+ [//influences]
+ [//])
+
+(exception: #export Invalid-Lux-Version)
+(exception: #export Module-Is-Not-Cached)
+(exception: #export Cannot-Pre-Load-Cache-More-Than-Once)
+(exception: #export Cannot-Delete-Cached-File)
+(exception: #export Cannot-Load-Definition)
+
+(def: cache
+ (Atom //.Cache)
+ (atom //.empty))
+
+(def: #export (load name)
+ (-> Text (Process Module))
+ (do io.Monad<IO>
+ [cache (atom.read cache)]
+ (case (dict.get name cache)
+ (#.Some module)
+ (process/wrap module)
+
+ #.None
+ (io.throw Module-Is-Not-Cached name))))
+
+(def: #export (cached target-dir)
+ (-> File (Process (List File)))
+ (do io.Monad<Process>
+ [roots (file.files target-dir)
+ root-modules (monad.map @ (: (-> File (Process (List File)))
+ (function recur [file]
+ (do @
+ [is-dir? (file.directory? file)]
+ (if is-dir?
+ (do @
+ [subs (file.files file)
+ cached-subs (monad.map @ recur subs)]
+ (wrap (list& (maybe.assume (///io.module target-dir file))
+ (list.concat cached-subs))))
+ (wrap (list))))))
+ roots)]
+ (wrap (list.concat root-modules))))
+
+(def: (delete file)
+ (-> File (Process Unit))
+ (do io.Monad<Process>
+ [deleted? (file.delete file)]
+ (if deleted?
+ (wrap [])
+ (io.throw Cannot-Delete-Cached-File file))))
+
+(def: (un-install target-dir module-name)
+ (-> File Text (Process Unit))
+ (do io.Monad<Process>
+ [#let [module-dir (///io.file target-dir module-name)]
+ files (file.files module-dir)
+ can-delete-module-dir? (<| (:: @ map (list.every? (bool/= true)))
+ (monad.map @ (function [file]
+ (do @
+ [? (file.directory? file)]
+ (if ?
+ (wrap false)
+ (do @
+ [_ (delete file)]
+ (wrap true)))))
+ files))]
+ (if can-delete-module-dir?
+ (delete module-dir)
+ (wrap []))))
+
+(def: no-aliases Aliases (dict.new text.Hash<Text>))
+
+(def: (source description)
+ (-> Text Source)
+ [["" +1 +0] +0 description])
+
+(def: (load-module source-dirs target-dir module-name)
+ (-> (List File) File Text (Process (List [Text Module])))
+ (do io.Monad<Process>
+ [#let [_ (log! (format "load-module #0: " module-name))]
+ description (file.read (///io.file target-dir (format module-name "/" //.descriptor-name)))
+ #let [_ (log! (format "load-module #1: " module-name))]]
+ (case (do e.Monad<Error>
+ [#let [_ (log! (format "load-module #1 #0: " module-name))]
+ [_ description] (syntax.read "" no-aliases (source (///io.blob-to-text description)))
+ #let [_ (log! (format "load-module #1 #1: " module-name))]]
+ (//description.read description))
+ (#e.Success [lux-file module])
+ (do @
+ [#let [_ (log! (format "load-module #2: " module-name " " lux-file))]
+ [file-name current-source-code] (///io.read source-dirs module-name)
+ #let [_ (log! (format "load-module #3: " module-name " " file-name))]]
+ (if (and (text/= lux-file file-name)
+ (n/= (get@ #.module-hash module)
+ (text/hash current-source-code)))
+ (wrap (list [module-name module]))
+ (do @
+ [_ (un-install target-dir module-name)]
+ (wrap (list)))))
+
+ (#e.Error error)
+ (do @
+ [#let [_ (log! "load-module #2 ERROR")]
+ _ (un-install target-dir module-name)]
+ (wrap (list))))))
+
+(type: Loader (-> Ident Blob (Error Top)))
+
+(def: (install target-dir load-def module-name module)
+ (-> File Loader Text Module (Process Module))
+ (do io.Monad<Process>
+ [definitions (monad.map @ (: (-> [Text Definition] (Process [Text Definition]))
+ (function [[def-name [def-type def-annotations _]]]
+ (do @
+ [def-blob (file.read (///io.file target-dir (format module-name "/" def-name)))
+ #let [def-ident [module-name def-name]]]
+ (case (load-def def-ident def-blob)
+ (#e.Success def-value)
+ (wrap [def-name [def-type def-annotations def-value]])
+
+ (#e.Error error)
+ (io.throw Cannot-Load-Definition
+ (format "Definition: " (%ident def-ident) "\n"
+ " Error:\n" error "\n"))))))
+ (get@ #.definitions module))]
+ (wrap (set@ #.definitions definitions module))))
+
+(def: (pre-load' source-dirs target-dir load-def)
+ (-> (List File) File Loader (Process //.Cache))
+ (do io.Monad<Process>
+ [#let [_ (log! "pre-load' #0")]
+ cached (cached target-dir)
+ #let [_ (log! (format "pre-load' #1 " (%list %t cached)))]
+ candidate-cache (|> cached
+ (monad.map @ (load-module source-dirs target-dir))
+ (:: @ map (|>> list.concat
+ (dict.from-list text.Hash<Text>))))
+ #let [_ (log! "pre-load' #2")]
+ #let [candidate-entries (dict.entries candidate-cache)
+ raw-influences (list/fold (function [[candidate-name candidate-module] influences]
+ (list/fold (//influences.track candidate-name)
+ influences
+ (get@ #.imports candidate-module)))
+ //influences.empty
+ candidate-entries)
+ pruned-influences (list/fold (function [[candidate-name candidate-module] influences]
+ (if (list.every? (function [module-name]
+ (dict.contains? module-name candidate-cache))
+ (get@ #.imports candidate-module))
+ influences
+ (//influences.untrack candidate-name influences)))
+ raw-influences
+ candidate-entries)
+ valid-cache (list/fold (function [candidate cache]
+ (if (dict.contains? candidate pruned-influences)
+ cache
+ (dict.remove candidate cache)))
+ candidate-cache
+ (dict.keys candidate-cache))]
+ #let [_ (log! "pre-load' #3")]]
+ (|> (dict.entries valid-cache)
+ (monad.map @ (function [[module-name module]]
+ (do @
+ [#let [_ (log! (format " PRE INSTALL: " module-name))]
+ loaded-module (install target-dir load-def module-name module)
+ #let [_ (log! (format "POST INSTALL: " module-name))]]
+ (wrap [module-name loaded-module]))))
+ (:: @ map (dict.from-list text.Hash<Text>)))))
+
+(def: (set-cache cache)
+ (-> //.Cache (Process Unit))
+ (do io.Monad<IO>
+ [swapped? (atom.compare-and-swap //.empty cache ..cache)]
+ (if swapped?
+ (wrap (#e.Success []))
+ (io.throw Cannot-Pre-Load-Cache-More-Than-Once ""))))
+
+(def: #export (pre-load source-dirs target-dir load-def)
+ (-> (List File) File Loader (Process Unit))
+ (do io.Monad<Process>
+ [loaded-cache (pre-load' source-dirs (///io.platform-target target-dir) load-def)]
+ (set-cache loaded-cache)))
+
+(def: #export (clean target-dir wanted-modules)
+ (-> File (Set Text) (Process Unit))
+ (do io.Monad<Process>
+ [cached (cached target-dir)
+ _ (|> cached
+ (list.filter (bool.complement (set.member? wanted-modules)))
+ (monad.map @ (un-install target-dir)))]
+ (wrap [])))
diff --git a/new-luxc/source/luxc/io.jvm.lux b/new-luxc/source/luxc/io.jvm.lux
index ef4a7fc8a..c932472f3 100644
--- a/new-luxc/source/luxc/io.jvm.lux
+++ b/new-luxc/source/luxc/io.jvm.lux
@@ -19,6 +19,7 @@
(exception: #export File-Not-Found)
(exception: #export Module-Not-Found)
+(exception: #export Cannot-Prepare-Module)
(def: sanitize
(-> Text Text)
@@ -49,7 +50,11 @@
(#e.Error error)
right)))
-(def: #export (read-module dirs name)
+(def: #export blob-to-text
+ (-> Blob Text)
+ (|>> [] String::new))
+
+(def: #export (read dirs name)
(-> (List File) Text (Process [File Text]))
(do io.Monad<Process>
[[path file] (: (Process [Text File])
@@ -58,9 +63,9 @@
(find-source dirs (format name lux-extension))
(io.fail (Module-Not-Found name))))
blob (file.read file)]
- (wrap [path (String::new blob)])))
+ (wrap [path (blob-to-text blob)])))
-(def: (platform-target root-target)
+(def: #export (platform-target root-target)
(-> File File)
(format root-target "/" (for {"JVM" "jvm"
"JS" "js"})))
@@ -72,11 +77,16 @@
(file.make-dir (sanitize (platform-target target-dir)))))
(def: #export (prepare-module target-dir module-name)
- (-> File Text (Process Bool))
- (|> module-name
- (format (platform-target target-dir) "/")
- sanitize
- file.make-dir))
+ (-> File Text (Process Unit))
+ (do io.Monad<Process>
+ [made-dir? (|> module-name
+ (format (platform-target target-dir) "/")
+ sanitize
+ file.make-dir)]
+ (if made-dir?
+ (wrap [])
+ (io.fail (Cannot-Prepare-Module (format "Module: " module-name "\n"
+ "Target: " target-dir "\n"))))))
(def: #export (write target name content)
(-> File Text Blob (Process Unit))
@@ -84,3 +94,19 @@
(format (platform-target target) "/")
sanitize
(file.write content)))
+
+(def: #export (module target-dir module-dir)
+ (-> File File (Maybe Text))
+ (case (text.split-with target-dir module-dir)
+ (#.Some ["" post])
+ (let [raw (text.replace-all file.separator "/" post)]
+ (if (text.starts-with? "/" raw)
+ (text.clip' +1 raw)
+ (#.Some raw)))
+
+ _
+ #.None))
+
+(def: #export (file target-dir file-name)
+ (-> File Text File)
+ (format target-dir file.separator (sanitize file-name)))
diff --git a/new-luxc/source/luxc/lang/host.jvm.lux b/new-luxc/source/luxc/lang/host.jvm.lux
index c980eab9d..6eb8aacbc 100644
--- a/new-luxc/source/luxc/lang/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/host.jvm.lux
@@ -56,8 +56,8 @@
(Method::invoke [loader
(array.from-list (list (:! Object class-name)
(:! Object byte-code)
- (:! Object (host.l2i 0))
- (:! Object (host.l2i (nat-to-int (host.array-length byte-code))))))]
+ (:! Object (host.long-to-int 0))
+ (:! Object (host.long-to-int (nat-to-int (host.array-length byte-code))))))]
ClassLoader::defineClass))
(def: (fetch-byte-code class-name store)
diff --git a/new-luxc/source/luxc/lang/host/jvm/def.lux b/new-luxc/source/luxc/lang/host/jvm/def.lux
index 8e90172d5..8c73c1086 100644
--- a/new-luxc/source/luxc/lang/host/jvm/def.lux
+++ b/new-luxc/source/luxc/lang/host/jvm/def.lux
@@ -266,13 +266,13 @@
writer)))]
[boolean-field Bool $t.boolean id]
- [byte-field Int $t.byte host.l2b]
- [short-field Int $t.short host.l2s]
- [int-field Int $t.int host.l2i]
+ [byte-field Int $t.byte host.long-to-byte]
+ [short-field Int $t.short host.long-to-short]
+ [int-field Int $t.int host.long-to-int]
[long-field Int $t.long id]
- [float-field Frac $t.float host.d2f]
+ [float-field Frac $t.float host.double-to-float]
[double-field Frac $t.double id]
- [char-field Nat $t.char (|>> nat-to-int host.l2i host.i2c)]
+ [char-field Nat $t.char (|>> nat-to-int host.long-to-int host.int-to-char)]
[string-field Text ($t.class "java.lang.String" (list)) id]
)
diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux
index 5f3711bbd..0b1904020 100644
--- a/new-luxc/source/luxc/lang/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux
@@ -128,10 +128,10 @@
(MethodVisitor::visitLdcInsn [(<prepare> value)]))))]
[boolean Bool id]
- [int Int host.l2i]
+ [int Int host.long-to-int]
[long Int id]
[double Frac id]
- [char Nat (|>> nat-to-int host.l2i host.i2c)]
+ [char Nat (|>> nat-to-int host.long-to-int host.int-to-char)]
[string Text id]
)
diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux
index a0e5bca97..b1e65c952 100644
--- a/new-luxc/source/luxc/lang/translation.lux
+++ b/new-luxc/source/luxc/lang/translation.lux
@@ -4,7 +4,8 @@
["ex" exception #+ exception:])
(concurrency ["P" promise]
["T" task])
- (data ["e" error]
+ (data [product]
+ ["e" error]
[text "text/" Hash<Text>]
text/format
(coll [list "list/" Functor<List>]
@@ -14,9 +15,13 @@
(type ["tc" check]))
[host]
[io #+ IO Process io]
- (world [file #+ File]))
+ (world [blob #+ Blob]
+ [file #+ File]))
(luxc ["&" lang]
["&." io]
+ [cache]
+ [cache/description]
+ [cache/io]
(lang [".L" module]
[".L" host]
[".L" macro]
@@ -35,9 +40,7 @@
[".T" expression]
[".T" eval]
[".T" imports])
- ["&." eval]
- ## [".L" cache]
- )
+ ["&." eval])
))
(def: analyse
@@ -156,27 +159,30 @@
(#e.Success [(set@ #.source source' compiler)
output]))))
-(def: (write-module target-dir module-name module artifacts)
- (-> File Text Module Artifacts (Process Unit))
+(for {"JVM" (as-is (host.import java/lang/String
+ (getBytes [String] #try (Array byte)))
+
+ (def: text-to-blob
+ (-> Text Blob)
+ (|>> (:! String)
+ (String::getBytes ["UTF-8"])
+ e.assume)))})
+
+(def: (write-module target-dir file-name module-name module artifacts)
+ (-> File Text Text Module Artifacts (Process Unit))
(do io.Monad<Process>
- [_ (monad.map @ (function [[name content]]
- (&io.write target-dir
- (format module-name "/" name (for {"JVM" ".class"
- "JS" ".js"}))
- content))
+ [_ (monad.map @ (product.uncurry (&io.write target-dir))
(dict.entries artifacts))]
- (wrap [])
- ## (&io.write (format module-dir "/" cacheL.descriptor-name)
- ## (text-to-blob (%code (cacheL.describe module))))
- ))
+ (&io.write target-dir
+ (format module-name "/" cache.descriptor-name)
+ (text-to-blob (%code (cache/description.write file-name module))))))
(def: no-aliases Aliases (dict.new text.Hash<Text>))
(def: #export (translate-module source-dirs target-dir module-name compiler)
(-> (List File) File Text Compiler (Process Compiler))
(do io.Monad<Process>
- [## _ (&io.prepare-module target-dir module-name)
- [file-name file-content] (&io.read-module source-dirs module-name)
+ [[file-name file-content] (&io.read source-dirs module-name)
#let [module-hash (text/hash file-content)
translate-module (translate-module source-dirs target-dir)]]
(case (macro.run' compiler
@@ -197,8 +203,8 @@
(wrap [module artifacts])))
(#e.Success [compiler [module artifacts]])
(do @
- [## _ (write-module target-dir module-name module artifacts)
- ]
+ [_ (&io.prepare-module target-dir module-name)
+ _ (write-module target-dir file-name module-name module artifacts)]
(wrap compiler))
(#e.Error error)
@@ -246,7 +252,8 @@
(do @
[_ (&io.prepare-target target)
_ (&io.write target (format hostL.runtime-class ".class") runtime-bc)
- _ (&io.write target (format hostL.function-class ".class") function-bc)]
+ _ (&io.write target (format hostL.function-class ".class") function-bc)
+ _ (cache/io.pre-load sources target (commonT.load-definition compiler))]
(wrap (set@ #.extensions
(:! Void
{#extensionL.analysis analysisE.defaults
@@ -261,5 +268,6 @@
(do io.Monad<Process>
[compiler (initialize sources target)
_ (translate-module sources target program compiler)
+ ## _ (cache/io.clean target ...)
#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 1132928d0..a4eb5b93b 100644
--- a/new-luxc/source/luxc/lang/translation/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux
@@ -1,16 +1,19 @@
(.module:
- [lux #- function]
- (lux (control ["ex" exception #+ exception:])
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
[io]
(concurrency [atom #+ Atom atom])
- (data ["e" error]
- [text]
+ (data ["e" error #+ Error]
+ [text "text/" Hash<Text>]
text/format
(coll [dict #+ Dict]))
+ [macro]
[host]
(world [blob #+ Blob]
[file #+ File]))
- (luxc (lang [".L" variable #+ Register]
+ (luxc [lang]
+ (lang [".L" variable #+ Register]
(host ["$" jvm]
(jvm ["$t" type]
["$d" def]
@@ -23,7 +26,11 @@
(host.import java/lang/Object)
-(host.import (java/lang/Class a))
+(host.import java/lang/reflect/Field
+ (get [#? Object] #try #? Object))
+
+(host.import (java/lang/Class c)
+ (getField [String] #try Field))
(host.import java/lang/ClassLoader
(loadClass [String] (Class Object)))
@@ -41,14 +48,16 @@
#context [Text Nat]
#anchor (Maybe [Label Register])})
-(exception: Unknown-Class)
-(exception: Class-Already-Stored)
-(exception: No-Function-Being-Compiled)
-(exception: Cannot-Overwrite-Artifact)
+(exception: #export Unknown-Class)
+(exception: #export Class-Already-Stored)
+(exception: #export No-Function-Being-Compiled)
+(exception: #export Cannot-Overwrite-Artifact)
+(exception: #export Cannot-Load-Definition)
+(exception: #export Invalid-Definition-Value)
(def: #export (with-artifacts action)
(All [a] (-> (Meta a) (Meta [Artifacts a])))
- (.function [compiler]
+ (function [compiler]
(case (action (update@ #.host
(|>> (:! Host)
(set@ #artifacts (dict.new text.Hash<Text>))
@@ -68,7 +77,7 @@
(def: #export (record-artifact name content)
(-> Text Blob (Meta Unit))
- (.function [compiler]
+ (function [compiler]
(if (|> compiler (get@ #.host) (:! Host) (get@ #artifacts) (dict.contains? name))
(ex.throw Cannot-Overwrite-Artifact name)
(#e.Success [(update@ #.host
@@ -80,7 +89,7 @@
(def: #export (store-class name byte-code)
(-> Text Bytecode (Meta Unit))
- (.function [compiler]
+ (function [compiler]
(let [store (|> (get@ #.host compiler)
(:! Host)
(get@ #store))]
@@ -91,7 +100,7 @@
(def: #export (load-class name)
(-> Text (Meta (Class Object)))
- (.function [compiler]
+ (function [compiler]
(let [host (:! Host (get@ #.host compiler))
store (|> host (get@ #store) atom.read io.run)]
(if (dict.contains? name store)
@@ -100,3 +109,28 @@
(def: #export value-field Text "_value")
(def: #export $Object $.Type ($t.class "java.lang.Object" (list)))
+
+(def: #export (load-definition compiler)
+ (-> Compiler
+ (-> Ident Blob (Error Top)))
+ (function [(^@ def-ident [def-module def-name]) def-bytecode]
+ (let [normal-name (format (lang.normalize-name def-name) (%n (text/hash def-name)))
+ class-name (format (text.replace-all "/" "." def-module) "." normal-name)]
+ (<| (macro.run compiler)
+ (do macro.Monad<Meta>
+ [_ (..store-class class-name def-bytecode)
+ class (..load-class class-name)]
+ (case (do e.Monad<Error>
+ [field (Class::getField [..value-field] class)]
+ (Field::get [#.None] field))
+ (#e.Success (#.Some def-value))
+ (wrap def-value)
+
+ (#e.Success #.None)
+ (lang.throw Invalid-Definition-Value (%ident def-ident))
+
+ (#e.Error error)
+ (lang.throw Cannot-Load-Definition
+ (format "Definition: " (%ident def-ident) "\n"
+ "Error:\n"
+ error))))))))
diff --git a/new-luxc/source/luxc/module/descriptor/annotation.lux b/new-luxc/source/luxc/module/descriptor/annotation.lux
deleted file mode 100644
index 8ac220d0f..000000000
--- a/new-luxc/source/luxc/module/descriptor/annotation.lux
+++ /dev/null
@@ -1,81 +0,0 @@
-(.module:
- lux
- (lux (control codec
- monad)
- (data [text]
- (text format
- ["l" lexer "l/" Monad<Lexer>])
- [number]
- error
- (coll [list "L/" Functor<List>])))
- ["&" ../common]
- [luxc ["&." parser]])
-
-(def: dummy-cursor Cursor ["" +1 +0])
-
-(do-template [<name> <code>]
- [(def: <name> &.Signal <code>)]
-
- [ident-signal "@"]
- [bool-signal "B"]
- [nat-signal "N"]
- [int-signal "I"]
- [deg-signal "D"]
- [frac-signal "R"]
- [text-signal "T"]
- [list-signal "%"]
- [dict-signal "#"]
- )
-
-(def: (encode-ident [module name])
- (-> Ident Text)
- (format ident-signal
- module &.ident-separator name
- &.stop-signal))
-
-(def: (encode-text value)
- (-> Text Text)
- (format text-signal
- (%t value)
- &.stop-signal))
-
-(def: (encode-ann-value value)
- (-> Ann-Value Text)
- (case value
- (^template [<tag> <signal> <encoder>]
- (<tag> value)
- (format <signal>
- (<encoder> value)
- &.stop-signal))
- ([#.BoolA bool-signal %b]
- [#.NatA nat-signal %n]
- [#.IntA int-signal %i]
- [#.DegA deg-signal %d]
- [#.FracA frac-signal %r]
- [#.TextA text-signal %t]
- [#.IdentA ident-signal %ident]
- [#.ListA list-signal (&.encode-list encode-ann-value)]
- [#.DictA dict-signal (&.encode-list (function [[k v]]
- (format (encode-text k)
- (encode-ann-value v))))])))
-
-(def: ann-value-decoder
- (l.Lexer Ann-Value)
- (with-expansions
- [<simple> (do-template [<tag> <lexer> <signal>]
- [(do l.Monad<Lexer>
- [])])]
- ($_ l.either
- <simple>
- (|> ... (l.after (l.text bool-signal)))
- )))
-
-(def: encode-anns
- (-> Anns Text)
- (&.encode-list (function [[ident value]]
- (format (encode-ident ident)
- (encode-ann-value value)))))
-
-(struct: #export _ (Codec Text Anns)
- (def: encode encode-anns)
- (def: decode decode-anns))
diff --git a/new-luxc/source/luxc/module/descriptor/common.lux b/new-luxc/source/luxc/module/descriptor/common.lux
deleted file mode 100644
index b123fe852..000000000
--- a/new-luxc/source/luxc/module/descriptor/common.lux
+++ /dev/null
@@ -1,37 +0,0 @@
-(.module:
- lux
- (lux (data [text]
- (text format
- ["l" lexer "l/" Monad<Lexer>])
- (coll [list "L/" Functor<List>]))))
-
-(type: #export Signal Text)
-
-(do-template [<name> <code>]
- [(def: #export <name> Signal <code>)]
-
- [cons-signal "\u0005"]
- [nil-signal "\u0006"]
- [stop-signal "\u0007"]
- )
-
-(do-template [<name> <code>]
- [(def: #export <name> Signal <code>)]
-
- [ident-separator "."]
- )
-
-(def: #export (encode-list encode-elem types)
- (All [a] (-> (-> a Text) (List a) Text))
- (format (|> (L/map encode-elem types)
- (text.join-with cons-signal))
- nil-signal))
-
-(def: #export (decode-list decode-elem)
- (All [a] (-> (l.Lexer a) (l.Lexer (List a))))
- (l.alt (<| (l.after (l.text nil-signal))
- (l/wrap []))
- (<| (l.seq decode-elem)
- (l.after (l.text cons-signal))
- (decode-list decode-elem))))
-
diff --git a/new-luxc/source/luxc/module/descriptor/type.lux b/new-luxc/source/luxc/module/descriptor/type.lux
deleted file mode 100644
index d72229832..000000000
--- a/new-luxc/source/luxc/module/descriptor/type.lux
+++ /dev/null
@@ -1,145 +0,0 @@
-(.module:
- lux
- (lux (control codec
- monad)
- (data [text]
- (text format
- ["l" lexer "l/" Monad<Lexer>])
- [number]
- ["e" error]
- (coll [list "L/" Functor<List>]))
- (lang [type "type/" Eq<Type>]))
- ["&" ../common])
-
-(do-template [<name> <code>]
- [(def: <name> &.Signal <code>)]
-
- [type-signal "T"]
- [primitive-signal "^"]
- [void-signal "0"]
- [unit-signal "1"]
- [product-signal "*"]
- [sum-signal "+"]
- [function-signal ">"]
- [application-signal "%"]
- [uq-signal "U"]
- [eq-signal "E"]
- [bound-signal "$"]
- [ex-signal "!"]
- [var-signal "?"]
- [named-signal "@"]
- )
-
-(def: (encode-type type)
- (-> Type Text)
- (if (or (is Type type)
- (type/= Type type))
- type-signal
- (case type
- (#.Primitive name params)
- (format primitive-signal name &.stop-signal (&.encode-list encode-type params))
-
- #.Void
- void-signal
-
- #.Unit
- unit-signal
-
- (^template [<tag> <prefix>]
- (<tag> left right)
- (format <prefix> (encode-type left) (encode-type right)))
- ([#.Product product-signal]
- [#.Sum sum-signal]
- [#.Function function-signal]
- [#.App application-signal])
-
-
- (^template [<tag> <prefix>]
- (<tag> env body)
- (format <prefix> (&.encode-list encode-type env) (encode-type body)))
- ([#.UnivQ uq-signal]
- [#.ExQ eq-signal])
-
- (^template [<tag> <prefix>]
- (<tag> idx)
- (format <prefix> (%i (nat-to-int idx)) &.stop-signal))
- ([#.Bound bound-signal]
- [#.Ex ex-signal]
- [#.Var var-signal])
-
- (#.Named [module name] type*)
- (format named-signal module &.ident-separator name &.stop-signal (encode-type type*))
- )))
-
-(def: type-decoder
- (l.Lexer Type)
- (l.rec
- (function [type-decoder]
- (with-expansions
- [<simple> (do-template [<type> <signal>]
- [(|> (l/wrap <type>) (l.after (l.text <signal>)))]
-
- [Type type-signal]
- [#.Void void-signal]
- [#.Unit unit-signal])
- <combinators> (do-template [<tag> <prefix>]
- [(do l.Monad<Lexer>
- [_ (l.text <prefix>)
- left type-decoder
- right type-decoder]
- (wrap (<tag> left right)))]
-
- [#.Product product-signal]
- [#.Sum sum-signal]
- [#.Function function-signal]
- [#.App application-signal])
- <abstractions> (do-template [<tag> <prefix>]
- [(do l.Monad<Lexer>
- [_ (l.text <prefix>)
- env (&.decode-list type-decoder)
- body type-decoder]
- (wrap (<tag> env body)))]
-
- [#.UnivQ uq-signal]
- [#.ExQ eq-signal])
- <wildcards> (do-template [<tag> <prefix>]
- [(do l.Monad<Lexer>
- [_ (l.text <prefix>)
- id (l.codec number.Codec<Text,Int>
- (l.some' l.digit))
- _ (l.text &.stop-signal)]
- (wrap (<tag> (int-to-nat id))))]
-
- [#.Bound bound-signal]
- [#.Ex ex-signal]
- [#.Var var-signal])]
- ($_ l.either
- (do l.Monad<Lexer>
- [_ (l.text primitive-signal)
- name (l.many' (l.none-of &.stop-signal))
- _ (l.text &.stop-signal)
- params (&.decode-list type-decoder)]
- (wrap (#.Primitive name params)))
- <simple>
- <combinators>
- <abstractions>
- <wildcards>
- (do l.Monad<Lexer>
- [_ (l.text named-signal)
- module (l.some' (l.none-of &.ident-separator))
- _ (l.text &.ident-separator)
- name (l.many' (l.none-of &.stop-signal))
- _ (l.text &.stop-signal)
- unnamed type-decoder]
- (wrap (#.Named [module name] unnamed)))
- )))))
-
-(def: (decode-type input)
- (-> Text (e.Error Type))
- (|> type-decoder
- (l.before l.end)
- (l.run input)))
-
-(struct: #export _ (Codec Text Type)
- (def: encode encode-type)
- (def: decode decode-type))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 12:50:59 +0000