diff options
author | Eduardo Julian | 2020-05-06 04:19:54 -0400 |
---|---|---|
committer | Eduardo Julian | 2020-05-06 04:19:54 -0400 |
commit | 3e524725cfb47cb56466a08ac290ed5a389748be (patch) | |
tree | 5ba247673e8a3b6d2e25df194b0f6011c2c0b436 | |
parent | 724372e2b023bccbb93e1fa40e3c92ed2ee7e36c (diff) |
Loading the artifacts from the cache and re-populating the analyser's state.
Diffstat (limited to '')
19 files changed, 601 insertions, 335 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux index f98438902..12bf96631 100644 --- a/new-luxc/source/luxc/lang/translation/jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm.lux @@ -40,18 +40,16 @@ ["." inst]]]] ) -(import: org/objectweb/asm/Label) +(import: #long java/lang/reflect/Field + (get [#? java/lang/Object] #try #? java/lang/Object)) -(import: java/lang/reflect/Field - (get [#? Object] #try #? Object)) +(import: #long (java/lang/Class a) + (getField [java/lang/String] #try java/lang/reflect/Field)) -(import: (java/lang/Class a) - (getField [String] #try Field)) +(import: #long java/lang/Object + (getClass [] (java/lang/Class java/lang/Object))) -(import: java/lang/Object - (getClass [] (Class Object))) - -(import: java/lang/ClassLoader) +(import: #long java/lang/ClassLoader) (type: #export ByteCode Binary) @@ -74,23 +72,23 @@ ["Class" class])) (def: (class-value class-name class) - (-> Text (Class Object) (Try Any)) - (case (Class::getField ..value-field class) + (-> Text (java/lang/Class java/lang/Object) (Try Any)) + (case (java/lang/Class::getField ..value-field class) (#try.Success field) - (case (Field::get #.None field) + (case (java/lang/reflect/Field::get #.None field) (#try.Success ?value) (case ?value (#.Some value) (#try.Success value) #.None - (exception.throw invalid-value class-name)) + (exception.throw ..invalid-value class-name)) (#try.Failure error) - (exception.throw cannot-load [class-name error])) + (exception.throw ..cannot-load [class-name error])) (#try.Failure error) - (exception.throw invalid-field [class-name ..value-field error]))) + (exception.throw ..invalid-field [class-name ..value-field error]))) (def: class-path-separator ".") @@ -103,7 +101,7 @@ (format lux-context "." (%.nat module-id) ..class-path-separator (%.nat artifact-id))) (def: (evaluate! library loader eval-class valueI) - (-> Library ClassLoader Text Inst (Try [Any Definition])) + (-> Library java/lang/ClassLoader Text Inst (Try [Any Definition])) (let [bytecode-name (..bytecode-name eval-class) bytecode (def.class #jvm.V1_6 #jvm.Public jvm.noneC @@ -121,12 +119,12 @@ (io.run (do (try.with io.monad) [_ (loader.store eval-class bytecode library) class (loader.load eval-class loader) - value (:: io.monad wrap (class-value eval-class class))] + value (:: io.monad wrap (..class-value eval-class class))] (wrap [value [eval-class bytecode]]))))) (def: (execute! library loader temp-label [class-name class-bytecode]) - (-> Library ClassLoader Text Definition (Try Any)) + (-> Library java/lang/ClassLoader Text Definition (Try Any)) (io.run (do (try.with io.monad) [existing-class? (|> (atom.read library) (:: io.monad map (dictionary.contains? class-name)) @@ -138,7 +136,7 @@ (loader.load class-name loader)))) (def: (define! library loader context valueI) - (-> Library ClassLoader generation.Context Inst (Try [Text Any Definition])) + (-> Library java/lang/ClassLoader generation.Context Inst (Try [Text Any Definition])) (let [class-name (..class-name context)] (do try.monad [[value definition] (evaluate! library loader class-name valueI)] @@ -158,7 +156,22 @@ (..execute! library loader)) (def: define! - (..define! library loader))))))) + (..define! library loader)) + + (def: (ingest context bytecode) + [(..class-name context) bytecode]) + + (def: (re-learn context [_ bytecode]) + (io.run + (loader.store (..class-name context) bytecode library))) + + (def: (re-load context [_ bytecode]) + (io.run + (do (try.with io.monad) + [#let [class-name (..class-name context)] + _ (loader.store class-name bytecode library) + class (loader.load class-name loader)] + (:: io.monad wrap (..class-value class-name class)))))))))) (def: #export $Variant (type.array ..$Value)) (def: #export $Tuple (type.array ..$Value)) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 70eb486f3..cabbb1154 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -429,16 +429,16 @@ #1) ## (type: Global -## (| Alias -## Definition)) -("lux def" Global - ("lux check type" - (#Named ["lux" "Global"] - (#Sum Alias - Definition))) +## (#Alias Alias) +## (#Definition Definition)) +("lux def type tagged" Global + (#Named ["lux" "Global"] + (#Sum Alias + Definition)) (record$ (#Cons [(tag$ ["lux" "doc"]) (text$ "Represents all the data associated with a global constant.")] #Nil)) + ["Alias" "Definition"] #1) ## (type: (Bindings k v) diff --git a/stdlib/source/lux/control/concurrency/actor.lux b/stdlib/source/lux/control/concurrency/actor.lux index 87bfabd4d..a4c345967 100644 --- a/stdlib/source/lux/control/concurrency/actor.lux +++ b/stdlib/source/lux/control/concurrency/actor.lux @@ -5,10 +5,10 @@ [control ["." function] ["." try (#+ Try)] - ["ex" exception (#+ exception:)] - ["." io (#+ IO io) ("#;." monad)] - ["p" parser - ["s" code (#+ Parser)]]] + ["." exception (#+ exception:)] + ["." io (#+ IO io) ("#@." monad)] + ["<>" parser + ["<c>" code (#+ Parser)]]] [data ["." product] [number @@ -16,7 +16,7 @@ [text ["%" format (#+ format)]] [collection - ["." list ("#;." monoid monad fold)]]] + ["." list ("#@." monoid monad fold)]]] ["." macro (#+ with-gensyms monad) ["." code] [syntax (#+ syntax:) @@ -27,14 +27,15 @@ abstract]] [// ["." atom (#+ Atom atom)] - ["." promise (#+ Promise Resolver) ("#;." monad)]]) + ["." promise (#+ Promise Resolver) ("#@." monad)]]) (exception: #export poisoned) (exception: #export (dead {actor-name Text} {message-name Text}) - (ex.report ["Actor" actor-name] - ["Message" message-name])) + (exception.report + ["Actor" actor-name] + ["Message" message-name])) (with-expansions [<Message> (as-is (-> s (Actor s) (Promise (Try s)))) @@ -43,7 +44,7 @@ [(Promise [<Message> Mailbox]) (Resolver [<Message> Mailbox])]))] - (def: (obituary [read write]) + (def: (pending [read write]) (All [a] (-> (Rec Mailbox [(Promise [a Mailbox]) @@ -51,7 +52,7 @@ (List a))) (case (promise.poll read) (#.Some [head tail]) - (#.Cons head (obituary tail)) + (#.Cons head (pending tail)) #.None #.Nil)) @@ -100,7 +101,7 @@ (do @ [_ (end error state)] (let [[_ resolve] (get@ #obituary (:representation self))] - (exec (io.run (resolve [error state (#.Cons head (..obituary tail))])) + (exec (io.run (resolve [error state (#.Cons head (..pending tail))])) (wrap [])))) (#try.Success state') @@ -108,36 +109,43 @@ self))) (def: #export (alive? actor) - (All [s] (-> (Actor s) Bit)) + (All [s] (-> (Actor s) (IO Bit))) (let [[obituary _] (get@ #obituary (:representation actor))] - (case (promise.poll obituary) - #.None - #1 + (io.io (case (promise.poll obituary) + #.None + yes - _ - #0))) + _ + no)))) + + (def: #export (obituary actor) + (All [s] (-> (Actor s) (IO (Maybe (Obituary s))))) + (let [[obituary _] (get@ #obituary (:representation actor))] + (io.io (promise.poll obituary)))) (def: #export (send message actor) {#.doc "Communicate with an actor through message passing."} (All [s] (-> (Message s) (Actor s) (IO Bit))) - (if (alive? actor) - (let [entry [message (promise.promise [])]] - (do io.monad - [|mailbox|&resolve (atom.read (get@ #mailbox (:representation actor)))] - (loop [[|mailbox| resolve] |mailbox|&resolve] - (case (promise.poll |mailbox|) - #.None - (do @ - [resolved? (resolve entry)] - (if resolved? - (do @ - [_ (atom.write (product.right entry) (get@ #mailbox (:representation actor)))] - (wrap #1)) - (recur |mailbox|&resolve))) - - (#.Some [_ |mailbox|']) - (recur |mailbox|'))))) - (io;wrap #0))) + (do io.monad + [alive? (..alive? actor)] + (if alive? + (let [entry [message (promise.promise [])]] + (do @ + [|mailbox|&resolve (atom.read (get@ #mailbox (:representation actor)))] + (loop [[|mailbox| resolve] |mailbox|&resolve] + (case (promise.poll |mailbox|) + #.None + (do @ + [resolved? (resolve entry)] + (if resolved? + (do @ + [_ (atom.write (product.right entry) (get@ #mailbox (:representation actor)))] + (wrap true)) + (recur |mailbox|&resolve))) + + (#.Some [_ |mailbox|']) + (recur |mailbox|'))))) + (wrap false)))) ) ) @@ -147,7 +155,7 @@ (def: (default-end cause state) (All [s] (-> Text s (Promise Any))) - (promise;wrap [])) + (promise@wrap [])) (def: #export default-behavior (All [s] (Behavior s)) @@ -159,16 +167,16 @@ "but allows the actor to handle previous messages.")} (All [s] (-> (Actor s) (IO Bit))) (send (function (_ state self) - (promise.resolved (ex.throw ..poisoned []))) + (promise.resolved (exception.throw ..poisoned []))) actor)) (template [<with> <resolve> <tag> <desc>] - [(def: #export (<with> name) + [(def: (<with> name) (-> Name cs.Annotations cs.Annotations) (|>> (#.Cons [(name-of <tag>) (code.tag name)]))) - (def: #export (<resolve> name) + (def: (<resolve> name) (-> Name (Meta Name)) (do macro.monad [constant (macro.find-def name)] @@ -190,11 +198,11 @@ (def: actor-decl^ (Parser [Text (List Text)]) - (p.either (s.form (p.and s.local-identifier (p.some s.local-identifier))) - (p.and s.local-identifier (:: p.monad wrap (list))))) + (<>.either (<c>.form (<>.and <c>.local-identifier (<>.some <c>.local-identifier))) + (<>.and <c>.local-identifier (:: <>.monad wrap (list))))) (template [<name> <desc>] - [(def: #export <name> + [(def: <name> (-> Text Text) (|>> (format <desc> "@")))] @@ -214,17 +222,17 @@ (def: behavior^ (Parser BehaviorC) - (let [handle-args ($_ p.and s.local-identifier s.local-identifier s.local-identifier) - stop-args ($_ p.and s.local-identifier s.local-identifier)] - (p.and (p.maybe (s.form (p.and (s.form (p.after (s.this! (' handle)) handle-args)) - s.any))) - (p.maybe (s.form (p.and (s.form (p.after (s.this! (' stop)) stop-args)) - s.any)))))) + (let [handle-args (<c>.tuple ($_ <>.and <c>.local-identifier <c>.local-identifier <c>.local-identifier)) + stop-args (<c>.tuple ($_ <>.and <c>.local-identifier <c>.local-identifier))] + (<>.and (<>.maybe (<c>.form (<>.and (<c>.form (<>.after (<c>.this! (' handle)) handle-args)) + <c>.any))) + (<>.maybe (<c>.form (<>.and (<c>.form (<>.after (<c>.this! (' stop)) stop-args)) + <c>.any)))))) (syntax: #export (actor: {export csr.export} {[_name _vars] actor-decl^} - {annotations (p.default cs.empty-annotations csr.annotations)} + {annotations (<>.default cs.empty-annotations csr.annotations)} state-type {[?handle ?stop] behavior^}) {#.doc (doc "Defines an actor, with its behavior and internal state." @@ -233,7 +241,7 @@ ((stop cause state) (:: promise.monad wrap - (log! (if (ex.match? ..poisoned cause) + (log! (if (exception.match? ..poisoned cause) (format "Counter was poisoned: " (%.nat state)) cause))))) @@ -253,7 +261,7 @@ g!behavior (code.local-identifier (behavior-name _name)) g!actor (code.local-identifier _name) g!new (code.local-identifier (new-name _name)) - g!vars (list;map code.local-identifier _vars)]] + g!vars (list@map code.local-identifier _vars)]] (wrap (list (` (type: (~+ (csw.export export)) ((~ g!type) (~+ g!vars)) (~ state-type))) (` (type: (~+ (csw.export export)) ((~ g!actor) (~+ g!vars)) @@ -303,24 +311,24 @@ (def: signature^ (Parser Signature) - (s.form ($_ p.and - (p.default (list) (s.tuple (p.some s.local-identifier))) - s.local-identifier - (p.some csr.typed-input) - s.local-identifier - s.local-identifier - s.any))) + (<c>.form ($_ <>.and + (<>.default (list) (<c>.tuple (<>.some <c>.local-identifier))) + <c>.local-identifier + (<>.some csr.typed-input) + <c>.local-identifier + <c>.local-identifier + <c>.any))) (def: reference^ (Parser [Name (List Text)]) - (p.either (s.form (p.and s.identifier (p.some s.local-identifier))) - (p.and s.identifier (:: p.monad wrap (list))))) + (<>.either (<c>.form (<>.and <c>.identifier (<>.some <c>.local-identifier))) + (<>.and <c>.identifier (:: <>.monad wrap (list))))) (syntax: #export (message: {export csr.export} {[actor-name actor-vars] reference^} {signature signature^} - {annotations (p.default cs.empty-annotations csr.annotations)} + {annotations (<>.default cs.empty-annotations csr.annotations)} body) {#.doc (doc "A message can access the actor's state through the state parameter." "A message can also access the actor itself through the self parameter." @@ -343,24 +351,24 @@ #let [message-name [current-module (get@ #name signature)] g!type (code.identifier (product.both function.identity state-name actor-name)) g!message (code.local-identifier (get@ #name signature)) - g!actor-vars (list;map code.local-identifier actor-vars) + g!actor-vars (list@map code.local-identifier actor-vars) actorC (` ((~ (code.identifier actor-name)) (~+ g!actor-vars))) - g!all-vars (|> (get@ #vars signature) (list;map code.local-identifier) (list;compose g!actor-vars)) - g!inputsC (|> (get@ #inputs signature) (list;map product.left)) - g!inputsT (|> (get@ #inputs signature) (list;map product.right)) + g!all-vars (|> (get@ #vars signature) (list@map code.local-identifier) (list@compose g!actor-vars)) + g!inputsC (|> (get@ #inputs signature) (list@map product.left)) + g!inputsT (|> (get@ #inputs signature) (list@map product.right)) g!state (|> signature (get@ #state) code.local-identifier) g!self (|> signature (get@ #self) code.local-identifier) g!actor-refs (: (List Code) (if (list.empty? actor-vars) (list) - (|> actor-vars list.size list.indices (list;map (|>> code.nat (~) ($) (`)))))) + (|> actor-vars list.size list.indices (list@map (|>> code.nat (~) ($) (`)))))) ref-replacements (|> (if (list.empty? actor-vars) (list) - (|> actor-vars list.size list.indices (list;map (|>> code.nat (~) ($) (`))))) + (|> actor-vars list.size list.indices (list@map (|>> code.nat (~) ($) (`))))) (: (List Code)) (list.zip2 g!all-vars) (: (List [Code Code]))) - g!outputT (list;fold (function (_ [g!var g!ref] outputT) + g!outputT (list@fold (function (_ [g!var g!ref] outputT) (code.replace g!var g!ref outputT)) (get@ #output signature) ref-replacements)]] @@ -373,7 +381,7 @@ (~ actorC) ((~! promise.Promise) ((~! try.Try) (~ (get@ #output signature)))))) (let [[(~ g!task) (~ g!resolve)] (: [((~! promise.Promise) ((~! try.Try) (~ g!outputT))) - (promise.Resolver ((~! try.Try) (~ g!outputT)))] + ((~! promise.Resolver) ((~! try.Try) (~ g!outputT)))] (promise.promise []))] ((~! io.run) ((~! do) (~! io.monad) [(~ g!sent?) (..send (function ((~ g!_) (~ g!state) (~ g!self)) @@ -398,6 +406,6 @@ (if (~ g!sent?) ((~' wrap) (~ g!task)) ((~' wrap) ((~! promise.resolved) - ((~! ex.throw) ..dead [(~ (code.text (%.name actor-name))) - (~ (code.text (%.name message-name)))]))))))))) + ((~! exception.throw) ..dead [(~ (code.text (%.name actor-name))) + (~ (code.text (%.name message-name)))]))))))))) ))))) diff --git a/stdlib/source/lux/control/try.lux b/stdlib/source/lux/control/try.lux index 749b05a53..f22da7a1b 100644 --- a/stdlib/source/lux/control/try.lux +++ b/stdlib/source/lux/control/try.lux @@ -110,7 +110,7 @@ (#Failure message) (error! message))) -(def: #export (maybe try) +(def: #export (to-maybe try) (All [a] (-> (Try a) (Maybe a))) (case try (#Success value) @@ -119,6 +119,16 @@ (#Failure message) #.None)) +(def: #export (from-maybe maybe) + (All [a] (-> (Maybe a) (Try a))) + (case maybe + (#.Some value) + (#Success value) + + #.None + (let [[module short] (name-of ..from-maybe)] + (#Failure ($_ "lux text concat" short " @ " module))))) + (macro: #export (default tokens compiler) {#.doc (doc "Allows you to provide a default value that will be used" "if a (Try x) value turns out to be #Failure." diff --git a/stdlib/source/lux/target/jvm/type/parser.lux b/stdlib/source/lux/target/jvm/type/parser.lux index 049d53f45..499776376 100644 --- a/stdlib/source/lux/target/jvm/type/parser.lux +++ b/stdlib/source/lux/target/jvm/type/parser.lux @@ -93,7 +93,7 @@ (|>> //.signature //signature.signature (<t>.run ..var') - try.maybe)) + try.to-maybe)) (def: #export name (-> (Type Var) Text) @@ -157,7 +157,7 @@ (|>> //.signature //signature.signature (<t>.run (<>.after (<t>.this <prefix>) ..class)) - try.maybe))] + try.to-maybe))] [lower? //signature.lower-prefix //.lower] [upper? //signature.upper-prefix //.upper] @@ -224,7 +224,7 @@ (|>> //.signature //signature.signature (<t>.run <parser>) - try.maybe))] + try.to-maybe))] [array? (Type Value) (do <>.monad diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index 625931913..3c23bf62c 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -44,18 +44,10 @@ [".D" lux]]]]]] [meta [archive (#+ Archive) - ["." signature] - ["." key (#+ Key)] ["." descriptor (#+ Module)] ["." artifact] ["." document]]]]]) -(def: #export (info host) - (-> Text Info) - {#.target host - #.version ///version.version - #.mode #.Build}) - (def: #export (state target module expander host-analysis host generate generation-bundle host-directive-bundle program extender) (All [anchor expression directive] (-> Host @@ -73,7 +65,7 @@ generation-state [generation-bundle (///generation.state host module)] eval (///analysis/evaluation.evaluator expander synthesis-state generation-state generate) analysis-state [(analysisE.bundle eval host-analysis) - (///analysis.state (..info target) host)]] + (///analysis.state (///analysis.info ///version.version target))]] [(dictionary.merge (luxD.bundle expander host-analysis program extender) host-directive-bundle) {#///directive.analysis {#///directive.state analysis-state @@ -280,9 +272,3 @@ temporary-payload (..get-current-payload temporary-payload)] (..iterate archive expander module source temporary-payload (..module-aliases analysis-module))))))})])) )))))})))) - -(def: #export key - (Key .Module) - (key.key {#signature.name (name-of ..compiler) - #signature.version ///version.version} - (module.new 0))) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 58a2d4b32..7707a154c 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -7,9 +7,7 @@ [control ["." try (#+ Try)] [concurrency - ["." promise (#+ Promise) ("#@." monad)]] - ["<>" parser - ["<b>" binary (#+ Parser)]]] + ["." promise (#+ Promise) ("#@." monad)]]] [data ["." binary (#+ Binary)] ["." bit] @@ -35,10 +33,7 @@ ["#." generation (#+ Buffer)] ["#." directive] [phase - ## TODO: Get rid of this import ASAP - ["." extension (#+ Extender)] - [analysis - ["." module]]]]] + [extension (#+ Extender)]]]] [meta ["." archive (#+ Archive) ["." descriptor (#+ Descriptor Module)] @@ -76,11 +71,6 @@ (_.and descriptor.writer (document.writer $.writer))) - (def: parser - (Parser [Descriptor (Document .Module)]) - (<>.and descriptor.parser - (document.parser $.parser))) - (def: (cache-module platform host target-dir module-file-name module-id extension [[descriptor document] output]) (All <type-vars> (-> <Platform> Host Path Path archive.ID Text [[Descriptor (Document Any)] Output] @@ -96,26 +86,10 @@ (monad.map ..monad write-artifact!) (: (Action (List Any)))) document (:: promise.monad wrap - (document.check //init.key document))] + (document.check $.key document))] (ioW.cache system host target-dir module-id (_.run ..writer [descriptor document]))))) - (def: (load-cache system host target-dir archive) - (All <type-vars> - (-> (file.System Promise) Host Path Archive (Promise (Try Archive)))) - (do (try.with promise.monad) - [all-loaded-caches (|> (archive.reservations archive) - (monad.map @ (function (_ [module-name module-id]) - (do @ - [data (ioW.load system host target-dir module-id) - payload (promise@wrap (<b>.run ..parser data))] - (wrap [module-name payload])))))] - (promise@wrap (monad.fold try.monad - (function (_ [module descriptor+document] archive) - (archive.add module descriptor+document archive)) - archive - all-loaded-caches)))) - ## TODO: Inline ASAP (def: initialize-buffer! (All <type-vars> @@ -128,9 +102,10 @@ (-> <Platform> (///generation.Operation anchor expression directive Any))) (get@ #runtime)) - (def: #export (initialize target host module expander host-analysis platform generation-bundle host-directive-bundle program extender) + (def: #export (initialize extension target host module expander host-analysis platform generation-bundle host-directive-bundle program extender) (All <type-vars> - (-> Path + (-> Text + Path Host Module Expander @@ -153,42 +128,18 @@ extender)] (do (try.with promise.monad) [_ (ioW.enable (get@ #&file-system platform) host target) - archive (ioW.thaw (get@ #&file-system platform) host target) - archive (load-cache (get@ #&file-system platform) host target archive)] + [archive analysis-state] (ioW.thaw extension (get@ #host platform) (get@ #&file-system platform) host target)] (|> (do ///phase.monad - [_ ..initialize-buffer! - _ (..compile-runtime! platform) - buffer ///generation.buffer] - (wrap [archive buffer])) - ///directive.lift-generation + [_ (///directive.lift-analysis + (///analysis.install analysis-state))] + (///directive.lift-generation + (do ///phase.monad + [_ ..initialize-buffer! + _ (..compile-runtime! platform) + buffer ///generation.buffer] + (wrap [archive buffer])))) (///phase.run' state) - promise@wrap))) - - ## (case (runtimeT.generate ## (initL.compiler (io.run js.init)) - ## (initL.compiler (io.run hostL.init-host)) - ## ) - ## ## (#try.Success [state disk-write]) - ## ## (do @ - ## ## [_ (&io.prepare-target target) - ## ## _ disk-write - ## ## ## _ (cache/io.pre-load sources target (commonT.load-definition state)) - ## ## ] - ## ## (wrap (|> state - ## ## (set@ [#.info #.mode] #.Build)))) - - ## (#try.Success [state [runtime-bc function-bc]]) - ## (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) - ## ## _ (cache/io.pre-load sources target (commonT.load-definition state)) - ## ] - ## (wrap (|> state - ## (set@ [#.info #.mode] #.Build)))) - - ## (#try.Failure error) - ## (io.fail error)) - ) + promise@wrap)))) (def: #export (compile target partial-host-extension expander platform host configuration archive extension state) (All <type-vars> @@ -198,7 +149,7 @@ {<State+> state} {(///.Compiler <State+> .Module Any) - ((//init.compiler expander syntax.prelude (get@ #write platform)) //init.key (list))})] + ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list))})] (loop [module source-module [archive state] [archive state]] (if (archive.archived? archive module) diff --git a/stdlib/source/lux/tool/compiler/language/lux.lux b/stdlib/source/lux/tool/compiler/language/lux.lux index f823c1eaf..d300ec243 100644 --- a/stdlib/source/lux/tool/compiler/language/lux.lux +++ b/stdlib/source/lux/tool/compiler/language/lux.lux @@ -5,7 +5,17 @@ ["<b>" binary (#+ Parser)]]] [data [format - ["_" binary (#+ Writer)]]]]) + ["_" binary (#+ Writer)]]]] + ["." / #_ + ["#." version] + [phase + [analysis + ["." module]]] + [/// + [meta + [archive + ["." signature] + ["." key (#+ Key)]]]]]) ## TODO: Remove #module-hash, #imports & #module-state ASAP. ## TODO: Not just from this parser, but from the lux.Module type. @@ -88,3 +98,9 @@ (<b>.maybe <b>.code) ## #module-state (:: <>.monad wrap #.Cached)))) + +(def: #export key + (Key .Module) + (key.key {#signature.name (name-of ..compiler) + #signature.version /version.version} + (module.new 0))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux index 8537064a4..59a1cf2eb 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux @@ -352,6 +352,12 @@ (let [[bundle state] bundle,state] (#try.Failure (locate-error (get@ #.cursor state) error)))))) +(def: #export (install state) + (-> .Lux (Operation Any)) + (function (_ [bundle _]) + (#try.Success [[bundle state] + []]))) + (template [<name> <type> <field> <value>] [(def: #export (<name> value) (-> <type> (Operation Any)) @@ -380,8 +386,14 @@ #.var-counter 0 #.var-bindings (list)}) -(def: #export (state info host) - (-> Info Any Lux) +(def: #export (info version host) + (-> Text Text Info) + {#.target host + #.version version + #.mode #.Build}) + +(def: #export (state info) + (-> Info Lux) {#.info info #.source ..dummy-source #.cursor .dummy-cursor @@ -393,4 +405,4 @@ #.seed 0 #.scope-type-vars (list) #.extensions [] - #.host host}) + #.host []}) diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux index b428a851d..e787b032d 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/generation.lux @@ -7,6 +7,7 @@ ["." exception (#+ exception:)] ["." function]] [data + [binary (#+ Binary)] ["." product] ["." name ("#@." equivalence)] ["." text ("#@." equivalence) @@ -49,7 +50,14 @@ (: (-> Text directive (Try Any)) execute!) (: (-> Context expression (Try [Text Any directive])) - define!)) + define!) + + (: (-> Context Binary directive) + ingest) + (: (-> Context directive (Try Any)) + re-learn) + (: (-> Context directive (Try Any)) + re-load)) (type: #export (State anchor expression directive) {#module Module diff --git a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux index 28f01bbcb..cae8c34dc 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux @@ -19,7 +19,7 @@ (type: #export ID Nat) -(type: Artifact +(type: #export Artifact {#id ID #name (Maybe Text)}) @@ -34,9 +34,13 @@ (:abstraction {#artifacts row.empty #resolver (dictionary.new text.hash)})) + (def: #export artifacts + (-> Registry (Row Artifact)) + (|>> :representation (get@ #artifacts))) + (def: next (-> Registry ID) - (|>> :representation (get@ #artifacts) row.size)) + (|>> ..artifacts row.size)) (def: #export (resource registry) (-> Registry [ID Registry]) diff --git a/stdlib/source/lux/tool/compiler/meta/io.lux b/stdlib/source/lux/tool/compiler/meta/io.lux index 271dcb79a..11faee222 100644 --- a/stdlib/source/lux/tool/compiler/meta/io.lux +++ b/stdlib/source/lux/tool/compiler/meta/io.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- Module Code) + [lux (#- Code) [data ["." text]] [world @@ -7,8 +7,6 @@ (type: #export Context Path) -(type: #export Module Text) - (type: #export Code Text) (def: #export (sanitize system) diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux index a40c8427f..c6865ebc1 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux @@ -2,23 +2,39 @@ [lux (#- Module) ["@" target (#+ Host)] [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control ["." try (#+ Try)] ["." exception (#+ exception:)] [concurrency - ["." promise (#+ Promise)]] + ["." promise (#+ Promise) ("#@." monad)]] [security - ["!" capability (#+ capability:)]]] + ["!" capability (#+ capability:)]] + ["<>" parser + ["<b>" binary (#+ Parser)]]] [data [binary (#+ Binary)] - ["." text - ["%" format (#+ format)]]] + ["." product] + ["." text ("#@." equivalence) + ["%" format (#+ format)]] + [collection + ["." list ("#@." functor)] + ["." dictionary (#+ Dictionary)] + ["." row (#+ Row)]]] [world - ["." file (#+ Path File Directory System)]]] - ["." // (#+ Module) + ["." file (#+ Path File Directory)]]] + ["." // ["/#" // - ["." archive (#+ Archive)]]]) + ["." archive (#+ Archive) + ["." artifact (#+ Artifact)] + ["." descriptor (#+ Module Descriptor)] + ["." document (#+ Document)]] + [// + [language + ["$" lux + ["." version] + ["." analysis] + ["." generation]]]]]]) (exception: #export (cannot-prepare {archive Path} {module-id archive.ID} @@ -29,30 +45,30 @@ ["Error" error])) (def: #export (archive system host root) - (-> (System Promise) Host Path Path) + (-> (file.System Promise) Host Path Path) (format root (:: system separator) host)) (def: #export (lux-archive system host root) - (-> (System Promise) Host Path Path) + (-> (file.System Promise) Host Path Path) (format (..archive system host root) (:: system separator) //.lux-context)) (def: (module system host root module-id) - (-> (System Promise) Host Path archive.ID Path) + (-> (file.System Promise) Host Path archive.ID Path) (format (..lux-archive system host root) (:: system separator) (%.nat module-id))) (def: #export (artifact system host root module-id name extension) - (-> (System Promise) Host Path archive.ID Text Text Path) + (-> (file.System Promise) Host Path archive.ID Text Text Path) (format (..module system host root module-id) (:: system separator) name extension)) (def: #export (prepare system host root module-id) - (-> (System Promise) Host Path archive.ID (Promise (Try Any))) + (-> (file.System Promise) Host Path archive.ID (Promise (Try Any))) (do promise.monad [#let [module (..module system host root module-id)] module-exists? (file.exists? promise.monad system module)] @@ -71,7 +87,7 @@ error]))))))) (def: #export (write system host root module-id name extension content) - (-> (System Promise) Host Path archive.ID Text Text Binary (Promise (Try Any))) + (-> (file.System Promise) Host Path archive.ID Text Text Binary (Promise (Try Any))) (do (try.with promise.monad) [artifact (: (Promise (Try (File Promise))) (file.get-file promise.monad system @@ -79,7 +95,7 @@ (!.use (:: artifact over-write) content))) (def: #export (enable system host root) - (-> (System Promise) Host Path (Promise (Try Any))) + (-> (file.System Promise) Host Path (Promise (Try Any))) (do (try.with promise.monad) [_ (: (Promise (Try (Directory Promise))) (file.get-directory promise.monad system root)) @@ -88,49 +104,166 @@ (wrap []))) (def: (general-descriptor system host root) - (-> (System Promise) Host Path Path) + (-> (file.System Promise) Host Path Path) (format (..archive system host root) (:: system separator) "general-descriptor")) (def: #export (freeze system host root archive) - (-> (System Promise) Host Path Archive (Promise (Try Any))) + (-> (file.System Promise) Host Path Archive (Promise (Try Any))) (do (try.with promise.monad) [file (: (Promise (Try (File Promise))) (file.get-file promise.monad system (..general-descriptor system host root)))] (!.use (:: file over-write) (archive.export ///.version archive)))) -(def: #export (thaw system host root) - (-> (System Promise) Host Path (Promise (Try Archive))) - (do promise.monad - [file (!.use (:: system file) (..general-descriptor system host root))] - (case file - (#try.Success file) - (do (try.with promise.monad) - [binary (!.use (:: file content) [])] - (:: promise.monad wrap (archive.import ///.version binary))) - - (#try.Failure error) - (wrap (#try.Success archive.empty))))) +(def: module-descriptor-file + "module-descriptor") (def: (module-descriptor system host root module-id) - (-> (System Promise) Host Path archive.ID Path) + (-> (file.System Promise) Host Path archive.ID Path) (format (..module system host root module-id) (:: system separator) - "module-descriptor")) + ..module-descriptor-file)) (def: #export (cache system host root module-id content) - (-> (System Promise) Host Path archive.ID Binary (Promise (Try Any))) + (-> (file.System Promise) Host Path archive.ID Binary (Promise (Try Any))) (do (try.with promise.monad) [file (: (Promise (Try (File Promise))) (file.get-file promise.monad system (..module-descriptor system host root module-id)))] (!.use (:: file over-write) content))) -(def: #export (load system host root module-id) - (-> (System Promise) Host Path archive.ID (Promise (Try Binary))) +(def: (read-module-descriptor system host root module-id) + (-> (file.System Promise) Host Path archive.ID (Promise (Try Binary))) (do (try.with promise.monad) [file (: (Promise (Try (File Promise))) (file.get-file promise.monad system (..module-descriptor system host root module-id)))] (!.use (:: file content) []))) + +(def: parser + (Parser [Descriptor (Document .Module)]) + (<>.and descriptor.parser + (document.parser $.parser))) + +(def: (fresh-analysis-state host) + (-> Host .Lux) + (analysis.state (analysis.info version.version host))) + +(def: (analysis-state host archive) + (-> Host Archive (Try .Lux)) + (do try.monad + [modules (: (Try (List [Module .Module])) + (monad.map @ (function (_ module) + (do @ + [[descriptor document] (archive.find module archive) + content (document.read $.key document)] + (wrap [module content]))) + (archive.archived archive)))] + (wrap (set@ #.modules modules (fresh-analysis-state host))))) + +(def: (cached-artifacts system host root module-id) + (-> (file.System Promise) Host Path archive.ID (Promise (Try (Dictionary Text Binary)))) + (do (try.with promise.monad) + [module-dir (!.use (:: system directory) (..module system host root module-id)) + cached-files (!.use (:: module-dir files) [])] + (|> cached-files + (list@map (function (_ file) + [(!.use (:: file name) []) + (!.use (:: file path) [])])) + (list.filter (|>> product.left (text@= ..module-descriptor-file) not)) + (monad.map @ (function (_ [name path]) + (do @ + [file (: (Promise (Try (File Promise))) + (!.use (:: system file) path)) + data (: (Promise (Try Binary)) + (!.use (:: file content) []))] + (wrap [name data])))) + (:: @ map (dictionary.from-list text.hash))))) + +(def: (loaded-document extension host module-id expected actual document) + (All [expression directive] + (-> Text (generation.Host expression directive) archive.ID (Row Artifact) (Dictionary Text Binary) (Document .Module) + (Try (Document .Module)))) + (do try.monad + [values (|> expected + row.to-list + (monad.fold @ (function (_ [artifact-id artifact-name] values) + (do @ + [data (try.from-maybe (dictionary.get (format (%.nat artifact-id) extension) actual)) + #let [context [module-id artifact-id] + directive (:: host ingest context data)]] + (case artifact-name + #.None + (do @ + [_ (:: host re-learn context directive)] + (wrap values)) + + (#.Some artifact-name) + (do @ + [value (:: host re-load context directive)] + (wrap (dictionary.put artifact-name value values)))))) + (: (Dictionary Text Any) + (dictionary.new text.hash)))) + content (document.read $.key document) + definitions (monad.map @ (function (_ [def-name def-global]) + (case def-global + (#.Alias alias) + (wrap [def-name (#.Alias alias)]) + + (#.Definition [exported? type annotations _]) + (do @ + [value (try.from-maybe (dictionary.get def-name values))] + (wrap [def-name (#.Definition [exported? type annotations value])])))) + (get@ #.definitions content))] + (wrap (document.write $.key (set@ #.definitions definitions content))))) + +(def: (load-definitions system host root module-id extension host-environment [descriptor document]) + (All [expression directive] + (-> (file.System Promise) Host Path archive.ID Text (generation.Host expression directive) + [Descriptor (Document .Module)] + (Promise (Try [Descriptor (Document .Module)])))) + (do (try.with promise.monad) + [actual (cached-artifacts system host root module-id) + #let [expected (|> descriptor (get@ #descriptor.registry) artifact.artifacts)] + document (promise@wrap (loaded-document extension host-environment module-id expected actual document))] + (wrap [descriptor document]))) + +(def: (load-every-reserved-module extension host-environment system host root archive) + (All [expression directive] + (-> Text (generation.Host expression directive) (file.System Promise) Host Path Archive (Promise (Try [Archive .Lux])))) + (do (try.with promise.monad) + [all-loaded-caches (|> archive + archive.reservations + (monad.map @ (function (_ [module-name module-id]) + (do @ + [data (..read-module-descriptor system host root module-id) + descriptor,document (promise@wrap (<b>.run ..parser data)) + descriptor,document (load-definitions system host root module-id extension host-environment descriptor,document)] + (wrap [module-name descriptor,document])))))] + (promise@wrap + (do try.monad + [archive (monad.fold try.monad + (function (_ [module descriptor+document] archive) + (archive.add module descriptor+document archive)) + archive + all-loaded-caches) + analysis-state (..analysis-state host archive)] + (wrap [archive + analysis-state]))))) + +(def: #export (thaw extension host-environment system host root) + (All [expression directive] + (-> Text (generation.Host expression directive) (file.System Promise) Host Path (Promise (Try [Archive .Lux])))) + (do promise.monad + [file (!.use (:: system file) (..general-descriptor system host root))] + (case file + (#try.Success file) + (do (try.with promise.monad) + [binary (!.use (:: file content) []) + archive (promise@wrap (archive.import ///.version binary))] + (..load-every-reserved-module extension host-environment system host root archive)) + + (#try.Failure error) + (wrap (#try.Success [archive.empty + (fresh-analysis-state host)]))))) diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 6310a47b9..469cc6e01 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -5,9 +5,9 @@ [abstract ["." monad (#+ Monad do)]] [control - ["." try (#+ Try) ("#;." functor)] + ["." try (#+ Try) ("#@." functor)] ["." exception (#+ Exception exception:)] - ["." io (#+ IO) ("#;." functor)] + ["." io (#+ IO) ("#@." functor)] [concurrency ["." promise (#+ Promise)]] [security @@ -35,6 +35,9 @@ (capability: #export (Can-Open ! capability) (can-open Path (! (Try (capability !))))) +(capability: #export (Can-See o) + (can-see [] o)) + (capability: #export (Can-Query ! o) (can-query [] (! (Try o)))) @@ -46,6 +49,14 @@ (`` (signature: #export (File !) (~~ (template [<name> <output>] + [(: (Can-See <output>) + <name>)] + + [name Text] + [path Path] + )) + + (~~ (template [<name> <output>] [(: (Can-Query ! <output>) <name>)] @@ -102,6 +113,18 @@ (~~ (template [<forge> <name>+] [(with-expansions [<rows> (template.splice <name>+)] (template [<name>] + [(def: <name> (<forge> (|>> (!.use (:: file <name>)))))] + + <rows>))] + + [..can-see + [[name] [path]]] + + )) + + (~~ (template [<forge> <name>+] + [(with-expansions [<rows> (template.splice <name>+)] + (template [<name>] [(def: <name> (<forge> (|>> (!.use (:: file <name>)) promise.future)))] <rows>))] @@ -115,15 +138,16 @@ [..can-delete [[delete]]])) - (def: move (..can-open - (|>> (!.use (:: file move)) (io;map (try;map async-file)) promise.future)))))) + (def: move + (..can-open + (|>> (!.use (:: file move)) (io@map (try@map async-file)) promise.future)))))) (def: (async-directory directory) (-> (Directory IO) (Directory Promise)) (`` (structure (~~ (template [<name> <async>] [(def: <name> (..can-query (|>> (!.use (:: directory <name>)) - (io;map (try;map (list@map <async>))) + (io@map (try@map (list@map <async>))) promise.future)))] [files ..async-file] @@ -137,7 +161,7 @@ (`` (structure (~~ (template [<name> <async>] [(def: <name> (..can-open - (|>> (!.use (:: system <name>)) (io;map (try;map <async>)) promise.future)))] + (|>> (!.use (:: system <name>)) (io@map (try@map <async>)) promise.future)))] [file ..async-file] [create-file ..async-file] @@ -199,7 +223,8 @@ [exists] [delete] [isFile] [isDirectory] [canRead] [canWrite] [canExecute])) - + + (getName [] java/lang/String) (length [] #io #try long) (listFiles [] #io #try #? [java/io/File]) (getAbsolutePath [] #io #try java/lang/String) @@ -265,6 +290,18 @@ (wrap data) (io.io (exception.throw cannot-read-all-data path))))))) + (def: name + (..can-see + (function (name _) + (|> path + java/io/File::new + java/io/File::getName)))) + + (def: path + (..can-see + (function (_ _) + path))) + (def: size (..can-query (function (size _) @@ -411,7 +448,8 @@ (rmdirSync [host.String] #try Any)) (import: JsPath - (sep host.String)) + (sep host.String) + (basename [host.String] host.String)) (import: (#static require [host.String] Any)) @@ -436,6 +474,18 @@ (function (content _) (io.io (Fs::readFileSync [path] (!fs)))))) + (def: name + (..can-see + (function (name _) + (|> (..require "path") + (:coerce JsPath) + (JsPath::basename path))))) + + (def: path + (..can-see + (function (_ _) + path))) + (def: size (..can-query (function (size _) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index 3e0820c10..3d40111f7 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -126,7 +126,7 @@ {(Promise (Try [(directive.State+ <parameters>) Archive (Buffer artifact)])) - (platform.initialize target host (get@ #/cli.module configuration) expander host-analysis platform generation-bundle host-directive-bundle program extender)}) + (platform.initialize extension target host (get@ #/cli.module configuration) expander host-analysis platform generation-bundle host-directive-bundle program extender)}) [archive state] (:share [<parameters>] {(Platform <parameters>) platform} diff --git a/stdlib/source/test/lux/abstract/equivalence.lux b/stdlib/source/test/lux/abstract/equivalence.lux index 7ae9b37af..b7db2ee70 100644 --- a/stdlib/source/test/lux/abstract/equivalence.lux +++ b/stdlib/source/test/lux/abstract/equivalence.lux @@ -4,50 +4,48 @@ [abstract/monad (#+ do)] [data ["." bit ("#@." equivalence)] - [text - ["%" format (#+ format)]] [number ["n" nat] ["i" int]]] [math - ["r" random (#+ Random)]]] + ["." random (#+ Random)]]] {1 ["." / (#+ Equivalence)]}) (def: #export test Test - (do r.monad - [leftN r.nat - rightN r.nat - leftI r.int - rightI r.int] - (<| (_.context (%.name (name-of /._))) + (do random.monad + [leftN random.nat + rightN random.nat + leftI random.int + rightI random.int] + (<| (_.covering /._) ($_ _.and - (_.test (%.name (name-of /.sum)) - (let [equivalence (/.sum n.equivalence i.equivalence)] - (and (bit@= (:: n.equivalence = leftN leftN) - (:: equivalence = (#.Left leftN) (#.Left leftN))) - (bit@= (:: n.equivalence = leftN rightN) - (:: equivalence = (#.Left leftN) (#.Left rightN))) - (bit@= (:: i.equivalence = leftI leftI) - (:: equivalence = (#.Right leftI) (#.Right leftI))) - (bit@= (:: i.equivalence = leftI rightI) - (:: equivalence = (#.Right leftI) (#.Right rightI)))))) - (_.test (%.name (name-of /.product)) - (let [equivalence (/.product n.equivalence i.equivalence)] - (and (bit@= (and (:: n.equivalence = leftN leftN) - (:: i.equivalence = leftI leftI)) - (:: equivalence = [leftN leftI] [leftN leftI])) - (bit@= (and (:: n.equivalence = leftN rightN) - (:: i.equivalence = leftI rightI)) - (:: equivalence = [leftN leftI] [rightN rightI]))))))))) + (_.cover [/.sum] + (let [equivalence (/.sum n.equivalence i.equivalence)] + (and (bit@= (:: n.equivalence = leftN leftN) + (:: equivalence = (#.Left leftN) (#.Left leftN))) + (bit@= (:: n.equivalence = leftN rightN) + (:: equivalence = (#.Left leftN) (#.Left rightN))) + (bit@= (:: i.equivalence = leftI leftI) + (:: equivalence = (#.Right leftI) (#.Right leftI))) + (bit@= (:: i.equivalence = leftI rightI) + (:: equivalence = (#.Right leftI) (#.Right rightI)))))) + (_.cover [/.product] + (let [equivalence (/.product n.equivalence i.equivalence)] + (and (bit@= (and (:: n.equivalence = leftN leftN) + (:: i.equivalence = leftI leftI)) + (:: equivalence = [leftN leftI] [leftN leftI])) + (bit@= (and (:: n.equivalence = leftN rightN) + (:: i.equivalence = leftI rightI)) + (:: equivalence = [leftN leftI] [rightN rightI]))))))))) (def: #export (spec (^open "_@.") generator) (All [a] (-> (Equivalence a) (Random a) Test)) - (do r.monad + (do random.monad [left generator right generator] - (<| (_.context (%.name (name-of /.Equivalence))) + (<| (_.with-cover [/.Equivalence]) ($_ _.and (_.test "Reflexivity." (_@= left left)) diff --git a/stdlib/source/test/lux/control/concurrency/actor.lux b/stdlib/source/test/lux/control/concurrency/actor.lux index cde83e09d..741b848cb 100644 --- a/stdlib/source/test/lux/control/concurrency/actor.lux +++ b/stdlib/source/test/lux/control/concurrency/actor.lux @@ -3,8 +3,8 @@ ["_" test (#+ Test)] [abstract/monad (#+ do)] [control - ["." try] - ["ex" exception] + ["." try (#+ Try)] + ["." exception (#+ exception:)] ["." io (#+ IO io)]] [data [number @@ -12,59 +12,95 @@ [text ["%" format (#+ format)]]] [math - ["r" random]]] + ["." random]]] {1 ["." / (#+ actor: message:) [// - ["." promise ("#;." monad)]]]}) + ["." promise (#+ Promise Resolver) ("#@." monad)]]]}) + +(exception: get-wrecked) (actor: Counter Nat - ((handle message state self) - (do (try.with promise.monad) - [#let [_ (log! "BEFORE")] - output (message state self) - #let [_ (log! "AFTER")]] - (wrap output))) + ((handle [message state self]) + (message state self)) - ((stop cause state) - (promise;wrap (log! (if (ex.match? /.poisoned cause) - (format "Counter was poisoned: " (%.nat state)) - cause))))) + ((stop [cause state]) + (promise@wrap []))) (message: #export Counter (count! {increment Nat} state self Nat) (let [state' (n.+ increment state)] - (promise;wrap (#try.Success [state' state'])))) + (promise@wrap (#try.Success [state' state'])))) (def: #export test Test - (do r.monad - [_ (wrap [])] - (<| (_.context (%.name (name-of /.Actor))) + (do random.monad + [initial-state random.nat] + (<| (_.covering /._) + (_.with-cover [/.Actor]) ($_ _.and - (_.test "Can check if an actor is alive." - (io.run (do io.monad - [counter (new@Counter 0)] - (wrap (/.alive? counter))))) - - (_.test "Can poison actors." - (io.run (do io.monad - [counter (new@Counter 0) - poisoned? (/.poison counter)] - (wrap (and poisoned? - (not (/.alive? counter))))))) - - (_.test "Cannot poison an already dead actor." - (io.run (do io.monad - [counter (new@Counter 0) - first-time (/.poison counter) - second-time (/.poison counter)] - (wrap (and first-time - (not second-time)))))) - - (:: r.monad wrap + (_.cover [/.alive?] + (io.run (do io.monad + [actor (/.spawn /.default-behavior 0)] + (/.alive? actor)))) + + (_.cover [/.poison] + (and (io.run (do io.monad + [actor (/.spawn /.default-behavior 0) + poisoned? (/.poison actor) + alive? (/.alive? actor)] + (wrap (and poisoned? + (not alive?))))) + (io.run (do io.monad + [actor (/.spawn /.default-behavior 0) + first-time? (/.poison actor) + second-time? (/.poison actor)] + (wrap (and first-time? + (not second-time?))))))) + + (let [inc! (: (/.Message Nat) + (function (_ state actor) + (promise@wrap + (#try.Success + (inc state)))))] + (:: random.monad wrap + (do promise.monad + [result (promise.future (do io.monad + [actor (/.spawn /.default-behavior 0) + sent? (/.send inc! actor)] + (wrap (#try.Success sent?))))] + (_.claim [/.Behavior /.Message + /.default-behavior /.spawn /.send] + (case result + (#try.Success outcome) + outcome + + (#try.Failure error) + false))))) + + (let [[read write] (: [(Promise Text) (Resolver Text)] + (promise.promise []))] + (:: random.monad wrap + (do promise.monad + [result (promise.future (do io.monad + [actor (/.spawn {#/.handle (function (_ message state self) + (message state self)) + #/.end (function (_ cause state) + (promise.future (write cause)))} + write) + _ (/.poison actor)] + (io.io (promise.poll read))))] + (_.claim [/.poisoned] + (case result + (#.Some error) + (exception.match? /.poisoned error) + + #.None + false))))) + + (:: random.monad wrap (do promise.monad [result (do (try.with promise.monad) [#let [counter (io.run (new@Counter 0))] @@ -74,11 +110,50 @@ (wrap (and (n.= 1 output-1) (n.= 2 output-2) (n.= 3 output-3))))] - (_.assert "Can send messages to actors." - (case result - (#try.Success outcome) - outcome + (_.claim [/.actor: /.message:] + (case result + (#try.Success outcome) + outcome + + (#try.Failure error) + false)))) + + (:: random.monad wrap + (do promise.monad + [result (do (try.with promise.monad) + [counter (promise.future (do io.monad + [counter (new@Counter 0) + _ (/.poison counter)] + (wrap (#try.Success counter))))] + (count! 1 counter))] + (_.claim [/.dead] + (case result + (#try.Success outcome) + false + + (#try.Failure error) + (exception.match? /.dead error))))) + + (let [die! (: (/.Message Nat) + (function (_ state actor) + (promise@wrap (exception.throw ..get-wrecked []))))] + (:: random.monad wrap + (do promise.monad + [result (promise.future (do io.monad + [actor (/.spawn /.default-behavior initial-state) + sent? (/.send die! actor) + alive? (/.alive? actor) + obituary (/.obituary actor)] + (wrap (#try.Success [actor sent? alive? obituary]))))] + (_.claim [/.Obituary /.obituary] + (case result + (^ (#try.Success [actor sent? alive? (#.Some [error state (list single-pending-message)])])) + (and sent? + (not alive?) + (exception.match? ..get-wrecked error) + (n.= initial-state state) + (is? die! single-pending-message)) - (#try.Failure _) - #0)))) + _ + false))))) )))) diff --git a/stdlib/source/test/lux/control/try.lux b/stdlib/source/test/lux/control/try.lux index 08c19794d..ef090c1a9 100644 --- a/stdlib/source/test/lux/control/try.lux +++ b/stdlib/source/test/lux/control/try.lux @@ -72,9 +72,9 @@ (_.cover [/.assume] (n.= expected (/.assume (/.succeed expected)))) - (_.cover [/.maybe] - (case [(/.maybe (/.succeed expected)) - (/.maybe (/.fail error))] + (_.cover [/.to-maybe] + (case [(/.to-maybe (/.succeed expected)) + (/.to-maybe (/.fail error))] [(#.Some actual) #.None] (n.= expected actual) diff --git a/stdlib/source/test/lux/control/writer.lux b/stdlib/source/test/lux/control/writer.lux index d33cd3969..09dd2aef5 100644 --- a/stdlib/source/test/lux/control/writer.lux +++ b/stdlib/source/test/lux/control/writer.lux @@ -16,10 +16,10 @@ ["." product] [number ["n" nat]] - ["." text ("#;." equivalence) + ["." text ("#@." equivalence) ["%" format (#+ format)]]] [math - ["r" random]]] + ["." random]]] {1 ["." / (#+ Writer)]}) @@ -34,26 +34,30 @@ (def: #export test Test - (do r.monad - [log (r.ascii 1) - left r.nat - right r.nat] - (<| (_.context (%.name (name-of /.Writer))) + (do random.monad + [log (random.ascii 1) + left random.nat + right random.nat] + (<| (_.covering /._) + (_.with-cover [/.Writer]) ($_ _.and - ($functor.spec (..injection text.monoid) ..comparison /.functor) - ($apply.spec (..injection text.monoid) ..comparison (/.apply text.monoid)) - ($monad.spec (..injection text.monoid) ..comparison (/.monad text.monoid)) + (_.with-cover [/.functor] + ($functor.spec (..injection text.monoid) ..comparison /.functor)) + (_.with-cover [/.apply] + ($apply.spec (..injection text.monoid) ..comparison (/.apply text.monoid))) + (_.with-cover [/.monad] + ($monad.spec (..injection text.monoid) ..comparison (/.monad text.monoid))) - (_.test "Can write any value." - (text;= log - (product.left (/.write log)))) - (let [lift (/.lift text.monoid io.monad) - (^open "io;.") io.monad] - (_.test "Can add writer functionality to any monad." - (|> (io.run (do (/.with text.monoid io.monad) - [a (lift (io;wrap left)) - b (wrap right)] - (wrap (n.+ a b)))) - product.right - (n.= (n.+ left right))))) + (_.cover [/.write] + (text@= log + (product.left (/.write log)))) + (_.cover [/.with /.lift] + (let [lift (/.lift text.monoid io.monad) + (^open "io@.") io.monad] + (|> (io.run (do (/.with text.monoid io.monad) + [a (lift (io@wrap left)) + b (wrap right)] + (wrap (n.+ a b)))) + product.right + (n.= (n.+ left right))))) )))) |