From 2e86fefe6f15877e8c46a45411a9cbd04b26e2e3 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 5 Dec 2017 22:55:11 -0400 Subject: - WIP: Caching. --- new-luxc/source/luxc/cache.lux | 9 + new-luxc/source/luxc/cache/description.lux | 147 +++++++++++++++ new-luxc/source/luxc/cache/influences.lux | 27 +++ new-luxc/source/luxc/cache/io.lux | 210 +++++++++++++++++++++ new-luxc/source/luxc/io.jvm.lux | 42 ++++- new-luxc/source/luxc/lang/host.jvm.lux | 4 +- new-luxc/source/luxc/lang/host/jvm/def.lux | 10 +- new-luxc/source/luxc/lang/host/jvm/inst.lux | 4 +- new-luxc/source/luxc/lang/translation.lux | 50 ++--- .../source/luxc/lang/translation/common.jvm.lux | 62 ++++-- .../source/luxc/module/descriptor/annotation.lux | 81 -------- new-luxc/source/luxc/module/descriptor/common.lux | 37 ---- new-luxc/source/luxc/module/descriptor/type.lux | 145 -------------- 13 files changed, 513 insertions(+), 315 deletions(-) create mode 100644 new-luxc/source/luxc/cache.lux create mode 100644 new-luxc/source/luxc/cache/description.lux create mode 100644 new-luxc/source/luxc/cache/influences.lux create mode 100644 new-luxc/source/luxc/cache/io.lux delete mode 100644 new-luxc/source/luxc/module/descriptor/annotation.lux delete mode 100644 new-luxc/source/luxc/module/descriptor/common.lux delete mode 100644 new-luxc/source/luxc/module/descriptor/type.lux (limited to 'new-luxc/source') 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)) + +(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] + ["ex" exception #+ exception:]) + (data [product] + ["e" error #+ Error] + [text "text/" Eq] + text/format + (coll [list "list/" Functor])) + (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 [ ] + ( left right) + (` ( (~ (write-type left)) (~ (write-type right))))) + ([#.Sum "Sum"] + [#.Product "Product"] + [#.Function "Function"] + [#.Apply "Apply"]) + + (^template [ ] + ( id) + (` ( (~ (code.nat id))))) + ([#.Bound "Bound"] + [#.Var "Var"] + [#.Ex "Ex"]) + + (^template [ ] + ( env body) + (` ( (~ (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 + [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] + [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)) 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] + [text "text/" Hash] + text/format + (coll [list "list/" Fold] + [dict #+ Dict] + [set #+ Set])) + (lang [syntax #+ Aliases]) + [io #+ Process "process/" Monad] + (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 + [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 + [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 + [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 + [#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)) + +(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 + [#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 + [#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 + [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 + [#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)))) + #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))))) + +(def: (set-cache cache) + (-> //.Cache (Process Unit)) + (do io.Monad + [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 + [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 + [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 [[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 + [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 [( 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/format (coll [list "list/" Functor] @@ -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 - [_ (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)) (def: #export (translate-module source-dirs target-dir module-name compiler) (-> (List File) File Text Compiler (Process Compiler)) (do io.Monad - [## _ (&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 [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/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)) @@ -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 + [_ (..store-class class-name def-bytecode) + class (..load-class class-name)] + (case (do e.Monad + [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]) - [number] - error - (coll [list "L/" Functor]))) - ["&" ../common] - [luxc ["&." parser]]) - -(def: dummy-cursor Cursor ["" +1 +0]) - -(do-template [ ] - [(def: &.Signal )] - - [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 [ ] - ( value) - (format - ( 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 - [ (do-template [ ] - [(do l.Monad - [])])] - ($_ l.either - - (|> ... (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]) - (coll [list "L/" Functor])))) - -(type: #export Signal Text) - -(do-template [ ] - [(def: #export Signal )] - - [cons-signal "\u0005"] - [nil-signal "\u0006"] - [stop-signal "\u0007"] - ) - -(do-template [ ] - [(def: #export Signal )] - - [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]) - [number] - ["e" error] - (coll [list "L/" Functor])) - (lang [type "type/" Eq])) - ["&" ../common]) - -(do-template [ ] - [(def: &.Signal )] - - [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 [ ] - ( left right) - (format (encode-type left) (encode-type right))) - ([#.Product product-signal] - [#.Sum sum-signal] - [#.Function function-signal] - [#.App application-signal]) - - - (^template [ ] - ( env body) - (format (&.encode-list encode-type env) (encode-type body))) - ([#.UnivQ uq-signal] - [#.ExQ eq-signal]) - - (^template [ ] - ( idx) - (format (%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 - [ (do-template [ ] - [(|> (l/wrap ) (l.after (l.text )))] - - [Type type-signal] - [#.Void void-signal] - [#.Unit unit-signal]) - (do-template [ ] - [(do l.Monad - [_ (l.text ) - left type-decoder - right type-decoder] - (wrap ( left right)))] - - [#.Product product-signal] - [#.Sum sum-signal] - [#.Function function-signal] - [#.App application-signal]) - (do-template [ ] - [(do l.Monad - [_ (l.text ) - env (&.decode-list type-decoder) - body type-decoder] - (wrap ( env body)))] - - [#.UnivQ uq-signal] - [#.ExQ eq-signal]) - (do-template [ ] - [(do l.Monad - [_ (l.text ) - id (l.codec number.Codec - (l.some' l.digit)) - _ (l.text &.stop-signal)] - (wrap ( (int-to-nat id))))] - - [#.Bound bound-signal] - [#.Ex ex-signal] - [#.Var var-signal])] - ($_ l.either - (do l.Monad - [_ (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))) - - - - - (do l.Monad - [_ (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)) -- cgit v1.2.3