diff options
Diffstat (limited to '')
37 files changed, 542 insertions, 238 deletions
diff --git a/stdlib/source/lux/control/security/capability.lux b/stdlib/source/lux/control/security/capability.lux index df875b1e9..54ea35281 100644 --- a/stdlib/source/lux/control/security/capability.lux +++ b/stdlib/source/lux/control/security/capability.lux @@ -3,12 +3,11 @@ [abstract [monad (#+ do)]] [control - ["p" parser] + ["<>" parser + ["<c>" code]] ["." io (#+ IO)] [concurrency - ["." promise (#+ Promise)]] - [parser - ["s" code]]] + ["." promise (#+ Promise)]]] [data [text ["%" format (#+ format)]] @@ -44,8 +43,8 @@ (syntax: #export (capability: {export reader.export} {declaration reader.declaration} - {annotations (p.maybe reader.annotations)} - {[forge input output] (s.form ($_ p.and s.local-identifier s.any s.any))}) + {annotations (<>.maybe reader.annotations)} + {[forge input output] (<c>.form ($_ <>.and <c>.local-identifier <c>.any <c>.any))}) (do {@ macro.monad} [this-module macro.current-module-name #let [[name vars] declaration] diff --git a/stdlib/source/lux/data/bit.lux b/stdlib/source/lux/data/bit.lux index d80606137..3c1bcc02d 100644 --- a/stdlib/source/lux/data/bit.lux +++ b/stdlib/source/lux/data/bit.lux @@ -23,8 +23,8 @@ (def: (hash value) (case value - #1 1 - #0 0))) + #0 2 + #1 3))) (template [<name> <identity> <op>] [(structure: #export <name> diff --git a/stdlib/source/lux/data/collection/list.lux b/stdlib/source/lux/data/collection/list.lux index 5c117a857..070778080 100644 --- a/stdlib/source/lux/data/collection/list.lux +++ b/stdlib/source/lux/data/collection/list.lux @@ -5,6 +5,7 @@ [monoid (#+ Monoid)] [apply (#+ Apply)] [equivalence (#+ Equivalence)] + [hash (#+ Hash)] [fold (#+ Fold)] [predicate (#+ Predicate)] ["." functor (#+ Functor)] @@ -311,6 +312,23 @@ #0 ))) +(structure: #export (hash super) + (All [a] (-> (Hash a) (Hash (List a)))) + + (def: &equivalence + (..equivalence (:: super &equivalence))) + + (def: (hash value) + (case value + #.Nil + 2 + + (#.Cons head tail) + ($_ n.* 3 + (n.+ (:: super hash head) + (hash tail))) + ))) + (structure: #export monoid (All [a] (Monoid (List a))) diff --git a/stdlib/source/lux/data/maybe.lux b/stdlib/source/lux/data/maybe.lux index 6d425011c..2bde551e7 100644 --- a/stdlib/source/lux/data/maybe.lux +++ b/stdlib/source/lux/data/maybe.lux @@ -3,6 +3,7 @@ [abstract [monoid (#+ Monoid)] [equivalence (#+ Equivalence)] + [hash (#+ Hash)] [apply (#+ Apply)] ["." functor (#+ Functor)] ["." monad (#+ Monad do)]]]) @@ -11,7 +12,9 @@ ## #.None ## (#.Some a)) -(structure: #export monoid (All [a] (Monoid (Maybe a))) +(structure: #export monoid + (All [a] (Monoid (Maybe a))) + (def: identity #.None) (def: (compose mx my) @@ -22,13 +25,17 @@ (#.Some x) (#.Some x)))) -(structure: #export functor (Functor Maybe) +(structure: #export functor + (Functor Maybe) + (def: (map f ma) (case ma #.None #.None (#.Some a) (#.Some (f a))))) -(structure: #export apply (Apply Maybe) +(structure: #export apply + (Apply Maybe) + (def: &functor ..functor) (def: (apply ff fa) @@ -39,7 +46,9 @@ _ #.None))) -(structure: #export monad (Monad Maybe) +(structure: #export monad + (Monad Maybe) + (def: &functor ..functor) (def: (wrap x) @@ -53,18 +62,34 @@ (#.Some mx) mx))) -(structure: #export (equivalence a-equivalence) (All [a] (-> (Equivalence a) (Equivalence (Maybe a)))) +(structure: #export (equivalence super) + (All [a] (-> (Equivalence a) (Equivalence (Maybe a)))) + (def: (= mx my) (case [mx my] [#.None #.None] #1 [(#.Some x) (#.Some y)] - (:: a-equivalence = x y) + (:: super = x y) _ #0))) +(structure: #export (hash super) + (All [a] (-> (Hash a) (Hash (Maybe a)))) + + (def: &equivalence + (..equivalence (:: super &equivalence))) + + (def: (hash value) + (case value + #.None + 2 + + (#.Some value) + (.nat ("lux i64 *" (.int 3) (.int (:: super hash value))))))) + (structure: #export (with monad) (All [M] (-> (Monad M) (Monad (All [a] (M (Maybe a)))))) diff --git a/stdlib/source/lux/data/name.lux b/stdlib/source/lux/data/name.lux index 897690144..e79398021 100644 --- a/stdlib/source/lux/data/name.lux +++ b/stdlib/source/lux/data/name.lux @@ -2,11 +2,12 @@ [lux #* [abstract [equivalence (#+ Equivalence)] + [hash (#+ Hash)] [order (#+ Order)] - [codec (#+ Codec)] - hash] + [codec (#+ Codec)]] [data - ["." text ("#@." monoid hash)]]]) + ["." text ("#@." equivalence monoid)] + ["." product]]]) ## (type: Name ## [Text Text]) @@ -20,12 +21,13 @@ [short short] ) -(structure: #export equivalence +(def: #export hash + (Hash Name) + (product.hash text.hash text.hash)) + +(def: #export equivalence (Equivalence Name) - - (def: (= [xmodule xname] [ymodule yname]) - (and (text@= xmodule ymodule) - (text@= xname yname)))) + (:: ..hash &equivalence)) (structure: #export order (Order Name) @@ -56,11 +58,3 @@ _ (#.Left (text@compose "Invalid format for Name: " input)))))) - -(structure: #export hash - (Hash Name) - - (def: &equivalence ..equivalence) - - (def: (hash [module name]) - ("lux i64 +" (text@hash module) (text@hash name)))) diff --git a/stdlib/source/lux/data/product.lux b/stdlib/source/lux/data/product.lux index 416aa4673..5c7475833 100644 --- a/stdlib/source/lux/data/product.lux +++ b/stdlib/source/lux/data/product.lux @@ -2,7 +2,8 @@ {#.doc "Functionality for working with tuples (particularly 2-tuples)."} [lux #* [abstract - [equivalence (#+ Equivalence)]]]) + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]]]) (template [<name> <type> <output>] [(def: #export (<name> xy) @@ -11,7 +12,8 @@ <output>))] [left a x] - [right b y]) + [right b y] + ) (def: #export (curry f) (All [a b c] @@ -53,3 +55,17 @@ (def: (= [lP rP] [lS rS]) (and (l@= lP lS) (r@= rP rS)))) + +(structure: #export (hash leftH rightH) + (All [l r] + (-> (Hash l) (Hash r) + (Hash (& l r)))) + + (def: &equivalence + (..equivalence (:: leftH &equivalence) + (:: rightH &equivalence))) + + (def: (hash [left right]) + ("lux i64 +" + (:: leftH hash left) + (:: rightH hash right)))) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index a1dff7792..f25f22035 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -248,8 +248,7 @@ (#.Right [[descriptor (document.write key analysis-module)] (|> final-buffer (row@map (function (_ [name directive]) - [(product.right name) - (write-directive directive)])))])])) + [name (write-directive directive)])))])])) (#.Some [source requirements temporary-payload]) (let [[temporary-buffer temporary-registry] temporary-payload] diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux index ea62e77fb..598f34db5 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux @@ -2,6 +2,7 @@ [lux (#- nat int rev) [abstract [equivalence (#+ Equivalence)] + [hash (#+ Hash)] [monad (#+ do)]] [control ["." function] @@ -140,6 +141,25 @@ _ false))) +(structure: #export (composite-hash super) + (All [a] (-> (Hash a) (Hash (Composite a)))) + + (def: &equivalence + (..composite-equivalence (:: super &equivalence))) + + (def: (hash value) + (case value + (#Variant [lefts right? value]) + ($_ n.* 2 + (:: n.hash hash lefts) + (:: bit.hash hash right?) + (:: super hash value)) + + (#Tuple members) + ($_ n.* 3 + (:: (list.hash super) hash members)) + ))) + (structure: pattern-equivalence (Equivalence Pattern) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux index 2e42e2c45..5ef2dab10 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux @@ -6,7 +6,9 @@ ["." try]] [data ["." text - ["%" format (#+ format)]]] + ["%" format (#+ format)]] + [number + ["n" nat]]] ["." macro]] [// (#+ Operation) [macro (#+ Expander)] @@ -18,7 +20,7 @@ ["." type]] [// ["." synthesis] - ["." generation] + ["." generation (#+ Context)] [/// ["." phase] [meta @@ -28,13 +30,10 @@ (type: #export Eval (-> Archive Nat Type Code (Operation Any))) -(def: #export (id prefix module count) - (-> Text Module Nat Text) - (format prefix - "$" - (text.replace-all "/" "$" module) - "$" - (%.nat count))) +(def: (context [module-id artifact-id]) + (-> Context Context) + ## TODO: Find a better way that doesn't rely on clever tricks. + [(n.- module-id 0) artifact-id]) (def: #export (evaluator expander synthesis-state generation-state generate) (All [anchor expression artifact] @@ -54,6 +53,6 @@ [exprS (|> exprA (synthesisP.phase archive) (phase.run synthesis-state))] (phase.run generation-state (do phase.monad - [exprO (generate archive exprS)] - (generation.evaluate! (..id "analysis" module count) - exprO))))))))) + [exprO (generate archive exprS) + module-id (generation.module-id module archive)] + (generation.evaluate! (..context [module-id count]) exprO))))))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux index 2500af6d3..8a6e0825d 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/generation.lux @@ -9,7 +9,7 @@ [data [binary (#+ Binary)] ["." product] - ["." name ("#@." equivalence)] + ["." name] ["." text ("#@." equivalence) ["%" format (#+ format)]] [number @@ -29,25 +29,25 @@ ["." artifact]]]]]) (type: #export Context [archive.ID artifact.ID]) -(type: #export (Buffer directive) (Row [Name directive])) +(type: #export (Buffer directive) (Row [Text directive])) (exception: #export (cannot-interpret {error Text}) (exception.report ["Error" error])) (template [<name>] - [(exception: #export (<name> {name Name}) + [(exception: #export (<name> {name Text}) (exception.report - ["Output" (%.name name)]))] + ["Output" (%.text name)]))] [cannot-overwrite-output] [no-buffer-for-saving-code] ) (signature: #export (Host expression directive) - (: (-> Text expression (Try Any)) + (: (-> Context expression (Try Any)) evaluate!) - (: (-> Text directive (Try Any)) + (: (-> directive (Try Any)) execute!) (: (-> Context expression (Try [Text Any directive])) define!) @@ -183,21 +183,27 @@ (Operation anchor expression directive Module)) (extension.read (get@ #module))) -(template [<name> <inputT>] - [(def: #export (<name> label code) - (All [anchor expression directive] - (-> Text <inputT> (Operation anchor expression directive Any))) - (function (_ (^@ state+ [bundle state])) - (case (:: (get@ #host state) <name> label code) - (#try.Success output) - (#try.Success [state+ output]) +(def: #export (evaluate! label code) + (All [anchor expression directive] + (-> Context expression (Operation anchor expression directive Any))) + (function (_ (^@ state+ [bundle state])) + (case (:: (get@ #host state) evaluate! label code) + (#try.Success output) + (#try.Success [state+ output]) - (#try.Failure error) - (exception.throw ..cannot-interpret error))))] + (#try.Failure error) + (exception.throw ..cannot-interpret error)))) - [evaluate! expression] - [execute! directive] - ) +(def: #export (execute! code) + (All [anchor expression directive] + (-> directive (Operation anchor expression directive Any))) + (function (_ (^@ state+ [bundle state])) + (case (:: (get@ #host state) execute! code) + (#try.Success output) + (#try.Success [state+ output]) + + (#try.Failure error) + (exception.throw ..cannot-interpret error)))) (def: #export (define! context code) (All [anchor expression directive] @@ -210,19 +216,14 @@ (#try.Failure error) (exception.throw ..cannot-interpret error)))) -(def: #export (save! execute? name code) +(def: #export (save! name code) (All [anchor expression directive] - (-> Bit Name directive (Operation anchor expression directive Any))) + (-> Text directive (Operation anchor expression directive Any))) (do {@ phase.monad} - [_ (if execute? - (do @ - [label (..gensym "save")] - (execute! label code)) - (wrap [])) - ?buffer (extension.read (get@ #buffer))] + [?buffer (extension.read (get@ #buffer))] (case ?buffer (#.Some buffer) - (if (row.any? (|>> product.left (name@= name)) buffer) + (if (row.any? (|>> product.left (text@= name)) buffer) (phase.throw ..cannot-overwrite-output [name]) (extension.update (set@ #buffer (#.Some (row.add [name code] buffer))))) @@ -273,6 +274,14 @@ (exception: #export no-context) +(def: #export (module-id module archive) + (All [anchor expression directive] + (-> Module Archive (Operation anchor expression directive archive.ID))) + (function (_ (^@ stateE [bundle state])) + (do try.monad + [module-id (archive.id module archive)] + (wrap [stateE module-id])))) + (def: #export (context archive) (All [anchor expression directive] (-> Archive (Operation anchor expression directive Context))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux index 2cc5c42b8..3edad4d3b 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux @@ -2,12 +2,14 @@ [lux (#- Name) [abstract [equivalence (#+ Equivalence)] + [hash (#+ Hash)] ["." monad (#+ do)]] [control ["." function] ["." try (#+ Try)] ["." exception (#+ exception:)]] [data + ["." product] ["." text ("#@." order) ["%" format (#+ Format format)]] [collection @@ -18,17 +20,21 @@ [meta [archive (#+ Archive)]]]) -(type: #export Name Text) +(type: #export Name + Text) (type: #export (Extension a) [Name (List a)]) -(structure: #export (equivalence input-equivalence) +(def: #export equivalence (All [a] (-> (Equivalence a) (Equivalence (Extension a)))) + (|>> list.equivalence + (product.equivalence text.equivalence))) - (def: (= [reference-name reference-inputs] [sample-name sample-inputs]) - (and (text@= reference-name sample-name) - (:: (list.equivalence input-equivalence) = reference-inputs sample-inputs)))) +(def: #export hash + (All [a] (-> (Hash a) (Hash (Extension a)))) + (|>> list.hash + (product.hash text.hash))) (with-expansions [<Bundle> (as-is (Dictionary Name (Handler s i o)))] (type: #export (Handler s i o) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux index 090f81842..b03dbd256 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux @@ -14,7 +14,9 @@ ["." text ["%" format (#+ format)]] [collection - ["." dictionary]]] + ["." dictionary]] + [number + ["n" nat]]] ["." macro ["." code]] ["." type (#+ :share :by-example) ("#@." equivalence) @@ -56,6 +58,11 @@ (#try.Failure error) (phase.throw ///.invalid-syntax [extension-name %.code inputs])))) +(def: (context [module-id artifact-id]) + (-> Context Context) + ## TODO: Find a better way that doesn't rely on clever tricks. + [module-id (n.- (inc artifact-id) 0)]) + ## TODO: Inline "evaluate!'" into "evaluate!" ASAP (def: (evaluate!' archive generate code//type codeS) (All [anchor expression directive] @@ -69,8 +76,8 @@ [module /////generation.module id /////generation.next codeG (generate archive codeS) - codeV (/////generation.evaluate! (/////analysis/evaluation.id "directive" module id) - codeG)] + module-id (/////generation.module-id module archive) + codeV (/////generation.evaluate! (..context [module-id id]) codeG)] (wrap [code//type codeG codeV])))) (def: #export (evaluate! archive type codeC) @@ -105,7 +112,7 @@ id (/////generation.learn name) module-id (phase.lift (archive.id module archive)) [target-name value directive] (/////generation.define! [module-id id] codeG) - _ (/////generation.save! false [(%.nat module-id) (%.nat id)] directive)] + _ (/////generation.save! (%.nat id) directive)] (wrap [code//type codeG value])))) (def: (definition archive name expected codeC) @@ -157,7 +164,7 @@ module-id (phase.lift (archive.id current-module archive)) id (<learn> extension) [target-name value directive] (/////generation.define! [module-id id] codeG) - _ (/////generation.save! false [(%.nat module-id) (%.nat id)] directive)] + _ (/////generation.save! (%.nat id) directive)] (wrap [codeG value]))))) (def: #export (<full> archive extension codeT codeC) @@ -382,7 +389,7 @@ (do phase.monad [programG (generate archive programS) artifact-id (/////generation.learn /////program.name)] - (/////generation.save! false [(%.nat module-id) (%.nat artifact-id)] (program [module-id artifact-id] programG)))) + (/////generation.save! (%.nat artifact-id) (program [module-id artifact-id] programG)))) (def: (def::program program) (All [anchor expression directive] diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux index 0737d9772..935baa3db 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux @@ -1078,8 +1078,8 @@ (list& (..with-anonymous-init class total-environment super-class inputsTI) method-definitions) (row.row))) - _ (//////generation.save! true ["" (%.nat artifact-id)] - [anonymous-class-name bytecode])] + _ (//////generation.execute! [anonymous-class-name bytecode]) + _ (//////generation.save! (%.nat artifact-id) [anonymous-class-name bytecode])] (anonymous-instance generate archive class total-environment)))])) (def: bundle::class diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/runtime.lux index 19594bac9..dc8fe6e92 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common-lisp/runtime.lux @@ -278,6 +278,6 @@ (Operation Any) (///.with-buffer (do ////.monad - [_ (///.save! true ["" ..prefix] - ..runtime)] + [_ (///.execute! ..runtime) + _ (///.save! ..prefix ..runtime)] (///.save-buffer! ..artifact)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux index 91689340f..54595bb75 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux @@ -115,5 +115,6 @@ (_.return (apply-poly (_.do "concat" (list @missing) @curried) @self)))))))) ))] - _ (/////generation.save! true ["" (%.nat (product.right function-name))] definition)] + _ (/////generation.execute! definition) + _ (/////generation.save! (%.nat (product.right function-name)) definition)] (wrap instantiation))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux index 78c6c94e1..ee594cde2 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux @@ -772,7 +772,8 @@ (def: #export generate (Operation [Registry Output]) (do ///////phase.monad - [_ (/////generation.save! true ["" "0"] ..runtime)] + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! "0" ..runtime)] (wrap [(|> artifact.empty artifact.resource product.right) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux index 5c39d5d32..d52d8afbc 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux @@ -110,9 +110,9 @@ fields methods (row.row))) - _ (generation.save! true ["" function-class] - [function-class - (format.run class.writer class)])] + #let [bytecode (format.run class.writer class)] + _ (generation.execute! [function-class bytecode]) + _ (generation.save! function-class [function-class bytecode])] (wrap instance))) (def: #export (apply generate archive [abstractionS inputsS]) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux index 0df1a5812..224fba5b9 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux @@ -530,8 +530,8 @@ ..try::method)) (row.row)))] (do ////.monad - [_ (generation.execute! class [class bytecode])] - (generation.save! .false ["" class] [class bytecode])))) + [_ (generation.execute! [class bytecode])] + (generation.save! class [class bytecode])))) (def: generate-function (Operation Any) @@ -587,8 +587,8 @@ (list& <init>::method apply::method+) (row.row)))] (do ////.monad - [_ (generation.execute! class [class bytecode])] - (generation.save! .false ["" class] [class bytecode])))) + [_ (generation.execute! [class bytecode])] + (generation.save! class [class bytecode])))) (def: #export generate (Operation Any) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux index c99ec5d8f..755caf660 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux @@ -40,20 +40,21 @@ (case inits #.Nil (do ///////phase.monad - [_ (/////generation.save! true ["" function-name] - function-definition)] + [_ (/////generation.execute! function-definition) + _ (/////generation.save! function-name function-definition)] (wrap (|> (_.var function-name) (_.apply/* inits)))) _ (do {@ ///////phase.monad} [@closure (:: @ map _.var (/////generation.gensym "closure")) - _ (/////generation.save! true ["" (_.code @closure)] - (_.function @closure - (|> (list.enumerate inits) - (list@map (|>> product.left ..capture))) - ($_ _.then - function-definition - (_.return (_.var function-name)))))] + #let [directive (_.function @closure + (|> (list.enumerate inits) + (list@map (|>> product.left ..capture))) + ($_ _.then + function-definition + (_.return (_.var function-name))))] + _ (/////generation.execute! directive) + _ (/////generation.save! (_.code @closure) directive)] (wrap (_.apply/* inits @closure))))) (def: input diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux index df70c74aa..06d187642 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux @@ -32,11 +32,12 @@ initsO+ (monad.map @ (generate archive) initsS+) bodyO (/////generation.with-anchor @loop (generate archive bodyS)) - _ (/////generation.save! true ["" (_.code @loop)] - (_.function @loop (|> initsS+ - list.enumerate - (list@map (|>> product.left (n.+ start) //case.register))) - (_.return bodyO)))] + #let [directive (_.function @loop (|> initsS+ + list.enumerate + (list@map (|>> product.left (n.+ start) //case.register))) + (_.return bodyO))] + _ (/////generation.execute! directive) + _ (/////generation.save! (_.code @loop) directive)] (wrap (_.apply/* initsO+ @loop)))) (def: #export (recur generate archive argsS+) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux index e5011d01a..e62faf9c6 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux @@ -364,6 +364,6 @@ (Operation (Buffer Statement)) (/////generation.with-buffer (do ///////phase.monad - [_ (/////generation.save! true ["" ..prefix] - ..runtime)] + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! ..prefix ..runtime)] /////generation.buffer))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux index bbe47a057..34368c147 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux @@ -233,16 +233,17 @@ (#reference.Foreign register) (..capture register))])))] - _ (///.save! true ["" @case] - ($_ _.then - (<| _.; - (_.set @caseL) - (_.closure (list (_.reference @caseL)) (list& [#0 @init] - @dependencies+)) - ($_ _.then - (_.; (_.set @cursor (_.array/* (list @init)))) - (_.; (_.set @savepoint (_.array/* (list)))) - pattern-matching!)) - (_.; (_.set @caseG @caseL))))] + #let [directive ($_ _.then + (<| _.; + (_.set @caseL) + (_.closure (list (_.reference @caseL)) (list& [#0 @init] + @dependencies+)) + ($_ _.then + (_.; (_.set @cursor (_.array/* (list @init)))) + (_.; (_.set @savepoint (_.array/* (list)))) + pattern-matching!)) + (_.; (_.set @caseG @caseL)))] + _ (///.execute! directive) + _ (///.save! @case directive)] (wrap (_.apply/* (list& initG (list@map product.right @dependencies+)) @caseG)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux index fe24f7911..d03d4babc 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux @@ -61,44 +61,45 @@ (_.; (_.set (..input post) (_.nth (|> post .int _.int) @curried))))) initialize-self! (list.indices arity))] - _ (///.save! true ["" function-name] - ($_ _.then - (<| _.; - (_.set @selfL) - (_.closure (list& (_.reference @selfL) closureG+) (list)) - ($_ _.then - (_.echo (_.string "'ello, world! ")) - (_.; (_.set @num-args (_.func-num-args/0 []))) - (_.echo @num-args) (_.echo (_.string " ~ ")) (_.echo arityG) - (_.echo (_.string text.new-line)) - (_.; (_.set @curried (_.func-get-args/0 []))) - (_.cond (list [(|> @num-args (_.= arityG)) - ($_ _.then - initialize! - (_.return bodyG))] - [(|> @num-args (_.> arityG)) - (let [arity-inputs (_.array-slice/3 [@curried (_.int +0) arityG]) - extra-inputs (_.array-slice/2 [@curried arityG]) - next (_.call-user-func-array/2 [@selfL arity-inputs]) - done (_.call-user-func-array/2 [next extra-inputs])] - ($_ _.then - (_.echo (_.string "STAGED ")) (_.echo (_.count/1 arity-inputs)) - (_.echo (_.string " + ")) (_.echo (_.count/1 extra-inputs)) - (_.echo (_.string text.new-line)) - (_.echo (_.string "@selfL ")) (_.echo @selfL) (_.echo (_.string text.new-line)) - (_.echo (_.string " next ")) (_.echo next) (_.echo (_.string text.new-line)) - (_.echo (_.string " done ")) (_.echo done) (_.echo (_.string text.new-line)) - (_.return done)))]) - ## (|> @num-args (_.< arityG)) - (let [@missing (_.var "missing")] - (_.return (<| (_.closure (list (_.reference @selfL) (_.reference @curried)) (list)) - ($_ _.then - (_.; (_.set @missing (_.func-get-args/0 []))) - (_.echo (_.string "NEXT ")) (_.echo (_.count/1 @curried)) - (_.echo (_.string " ")) (_.echo (_.count/1 @missing)) - (_.echo (_.string " ")) (_.echo (_.count/1 (_.array-merge/+ @curried (list @missing)))) - (_.echo (_.string text.new-line)) - (_.return (_.call-user-func-array/2 [@selfL (_.array-merge/+ @curried (list @missing))]))))))) - )) - (_.; (_.set @selfG @selfL))))] + #let [directive ($_ _.then + (<| _.; + (_.set @selfL) + (_.closure (list& (_.reference @selfL) closureG+) (list)) + ($_ _.then + (_.echo (_.string "'ello, world! ")) + (_.; (_.set @num-args (_.func-num-args/0 []))) + (_.echo @num-args) (_.echo (_.string " ~ ")) (_.echo arityG) + (_.echo (_.string text.new-line)) + (_.; (_.set @curried (_.func-get-args/0 []))) + (_.cond (list [(|> @num-args (_.= arityG)) + ($_ _.then + initialize! + (_.return bodyG))] + [(|> @num-args (_.> arityG)) + (let [arity-inputs (_.array-slice/3 [@curried (_.int +0) arityG]) + extra-inputs (_.array-slice/2 [@curried arityG]) + next (_.call-user-func-array/2 [@selfL arity-inputs]) + done (_.call-user-func-array/2 [next extra-inputs])] + ($_ _.then + (_.echo (_.string "STAGED ")) (_.echo (_.count/1 arity-inputs)) + (_.echo (_.string " + ")) (_.echo (_.count/1 extra-inputs)) + (_.echo (_.string text.new-line)) + (_.echo (_.string "@selfL ")) (_.echo @selfL) (_.echo (_.string text.new-line)) + (_.echo (_.string " next ")) (_.echo next) (_.echo (_.string text.new-line)) + (_.echo (_.string " done ")) (_.echo done) (_.echo (_.string text.new-line)) + (_.return done)))]) + ## (|> @num-args (_.< arityG)) + (let [@missing (_.var "missing")] + (_.return (<| (_.closure (list (_.reference @selfL) (_.reference @curried)) (list)) + ($_ _.then + (_.; (_.set @missing (_.func-get-args/0 []))) + (_.echo (_.string "NEXT ")) (_.echo (_.count/1 @curried)) + (_.echo (_.string " ")) (_.echo (_.count/1 @missing)) + (_.echo (_.string " ")) (_.echo (_.count/1 (_.array-merge/+ @curried (list @missing)))) + (_.echo (_.string text.new-line)) + (_.return (_.call-user-func-array/2 [@selfL (_.array-merge/+ @curried (list @missing))]))))))) + )) + (_.; (_.set @selfG @selfL)))] + _ (///.execute! directive) + _ (///.save! function-name directive)] (wrap @selfG))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux index 1b68c0b7a..19b3fa46d 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux @@ -29,16 +29,17 @@ initsO+ (monad.map @ generate initsS+) bodyO (///.with-anchor @loopL (generate bodyS)) - _ (///.save! true ["" @loop] - ($_ _.then - (<| _.; - (_.set @loopL) - (_.closure (list (_.reference @loopL)) - (|> initsS+ - list.enumerate - (list@map (|>> product.left (n.+ start) //case.register [#0]))) - (_.return bodyO))) - (_.; (_.set @loopG @loopL))))] + #let [directive ($_ _.then + (<| _.; + (_.set @loopL) + (_.closure (list (_.reference @loopL)) + (|> initsS+ + list.enumerate + (list@map (|>> product.left (n.+ start) //case.register [#0]))) + (_.return bodyO))) + (_.; (_.set @loopG @loopL)))] + _ (///.execute! directive) + _ (///.save! @loop directive)] (wrap (_.apply/* initsO+ @loopG)))) (def: #export (recur generate argsS+) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux index 3adf01716..c7a8a4eeb 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux @@ -301,6 +301,6 @@ (Operation Any) (///.with-buffer (do ////.monad - [_ (///.save! true ["" ..prefix] - ..runtime)] + [_ (///.execute! ..runtime) + _ (///.save! ..prefix ..runtime)] (///.save-buffer! ..artifact)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux index 61796bb40..dd99cb47a 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux @@ -229,10 +229,11 @@ (#///////reference.Foreign register) (..capture register)))))] - _ (/////generation.save! true ["" (_.code @case)] - (_.def @case (list& @init @dependencies+) - ($_ _.then - (_.set (list @cursor) (_.list (list @init))) - (_.set (list @savepoint) (_.list (list))) - pattern-matching!)))] + #let [directive (_.def @case (list& @init @dependencies+) + ($_ _.then + (_.set (list @cursor) (_.list (list @init))) + (_.set (list @savepoint) (_.list (list))) + pattern-matching!))] + _ (/////generation.execute! directive) + _ (/////generation.save! (_.code @case) directive)] (wrap (_.apply/* @case (list& initG @dependencies+))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux index d10f54edc..cc3e27165 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux @@ -40,20 +40,21 @@ (case inits #.Nil (do ///////phase.monad - [_ (/////generation.save! true ["" function-name] - function-definition)] + [_ (/////generation.execute! function-definition) + _ (/////generation.save! function-name function-definition)] (wrap (_.apply/* (_.var function-name) inits))) _ (do {@ ///////phase.monad} [@closure (:: @ map _.var (/////generation.gensym "closure")) - _ (/////generation.save! true ["" (_.code @closure)] - (_.def @closure - (|> (list.enumerate inits) - (list@map (|>> product.left ..capture))) - ($_ _.then - function-definition - (_.return (_.var function-name)))))] + #let [directive (_.def @closure + (|> (list.enumerate inits) + (list@map (|>> product.left ..capture))) + ($_ _.then + function-definition + (_.return (_.var function-name))))] + _ (/////generation.execute! function-definition) + _ (/////generation.save! (_.code @closure) directive)] (wrap (_.apply/* @closure inits))))) (def: input diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux index 27c74faee..2edbab5ec 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux @@ -32,11 +32,12 @@ initsO+ (monad.map @ (generate archive) initsS+) bodyO (/////generation.with-anchor @loop (generate archive bodyS)) - _ (/////generation.save! true ["" (_.code @loop)] - (_.def @loop (|> initsS+ - list.enumerate - (list@map (|>> product.left (n.+ start) //case.register))) - (_.return bodyO)))] + #let [directive (_.def @loop (|> initsS+ + list.enumerate + (list@map (|>> product.left (n.+ start) //case.register))) + (_.return bodyO))] + _ (/////generation.execute! directive) + _ (/////generation.save! (_.code @loop) directive)] (wrap (_.apply/* @loop initsO+)))) (def: #export (recur generate archive argsS+) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux index d3d1d532a..aa49950f0 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux @@ -340,7 +340,8 @@ (Operation (Buffer (Statement Any))) (/////generation.with-buffer (do ///////phase.monad - [_ (/////generation.save! true ["" ..prefix] - (<| (_.comment "-*- coding: utf-8 -*-") - ..runtime))] + [#let [directive (<| (_.comment "-*- coding: utf-8 -*-") + ..runtime)] + _ (/////generation.execute! directive) + _ (/////generation.save! ..prefix directive)] /////generation.buffer))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux index 8d2e73a9d..eda4d8a60 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux @@ -296,6 +296,6 @@ (Operation (Buffer (Statement Any))) (/////generation.with-buffer (do ///////phase.monad - [_ (/////generation.save! true ["" ..prefix] - ..runtime)] + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! ..prefix ..runtime)] /////generation.buffer))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux index 992701393..34c1edeaf 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux @@ -136,16 +136,16 @@ (with-vars [error] (_.with-exception-handler (_.lambda [(list error) #.None] - (..left error)) + (..left error)) (_.lambda [(list) #.None] - (..right (_.apply/* op (list ..unit))))))) + (..right (_.apply/* op (list ..unit))))))) (runtime: (lux//program-args program-args) (with-vars [@loop @input @output] (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] - (_.if (_.eqv?/2 _.nil @input) - @output - (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) + (_.if (_.eqv?/2 _.nil @input) + @output + (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) (def: runtime//lux @@ -262,6 +262,6 @@ (Operation Any) (///.with-buffer (do ////.monad - [_ (///.save! true ["" ..prefix] - ..runtime)] + [_ (///.execute! ..runtime) + _ (///.save! ..prefix ..runtime)] (///.save-buffer! "")))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux index 12be82b11..2c6b8ab6f 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux @@ -9,6 +9,7 @@ ["." exception (#+ exception:)]] [data ["." sum] + ["." product] ["." maybe] ["." bit ("#@." equivalence)] ["." text ("#@." equivalence) @@ -450,6 +451,10 @@ (Equivalence Member) (sum.equivalence n.equivalence n.equivalence)) +(def: member-hash + (Hash Member) + (sum.hash n.hash n.hash)) + (structure: #export access-equivalence (Equivalence Access) @@ -521,6 +526,51 @@ _ false))) +(structure: (path'-hash super) + (All [a] (-> (Hash a) (Hash (Path' a)))) + + (def: &equivalence + (..path'-equivalence (:: super &equivalence))) + + (def: (hash value) + (case value + #Pop + 2 + + (#Access access) + (n.* 3 (:: ..access-hash hash access)) + + (#Bind register) + (n.* 5 (:: n.hash hash register)) + + (#Bit-Fork when then else) + ($_ n.* 7 + (:: bit.hash hash when) + (hash then) + (:: (maybe.hash (path'-hash super)) hash else)) + + (^template [<factor> <tag> <hash>] + (<tag> cons) + (let [case-hash (product.hash <hash> + (path'-hash super)) + cons-hash (product.hash case-hash (list.hash case-hash))] + (n.* <factor> (:: cons-hash hash cons)))) + ([11 #I64-Fork i64.hash] + [13 #F64-Fork f.hash] + [17 #Text-Fork text.hash]) + + (^template [<factor> <tag>] + (<tag> fork) + (let [recur-hash (path'-hash super) + fork-hash (product.hash recur-hash recur-hash)] + (n.* <factor> (:: fork-hash hash fork)))) + ([19 #Alt] + [23 #Seq]) + + (#Then body) + (n.* 29 (:: super hash body)) + ))) + (structure: (branch-equivalence (^open "/@.")) (All [a] (-> (Equivalence a) (Equivalence (Branch a)))) @@ -551,6 +601,37 @@ _ false))) +(structure: (branch-hash super) + (All [a] (-> (Hash a) (Hash (Branch a)))) + + (def: &equivalence + (..branch-equivalence (:: super &equivalence))) + + (def: (hash value) + (case value + (#Let [input register body]) + ($_ n.* 2 + (:: super hash input) + (:: n.hash hash register) + (:: super hash body)) + + (#If [test then else]) + ($_ n.* 3 + (:: super hash test) + (:: super hash then) + (:: super hash else)) + + (#Get [path record]) + ($_ n.* 5 + (:: (list.hash ..member-hash) hash path) + (:: super hash record)) + + (#Case [input path]) + ($_ n.* 7 + (:: super hash input) + (:: (..path'-hash super) hash path)) + ))) + (structure: (loop-equivalence (^open "/@.")) (All [a] (-> (Equivalence a) (Equivalence (Loop a)))) @@ -568,6 +649,25 @@ _ false))) +(structure: (loop-hash super) + (All [a] (-> (Hash a) (Hash (Loop a)))) + + (def: &equivalence + (..loop-equivalence (:: super &equivalence))) + + (def: (hash value) + (case value + (#Scope [start inits iteration]) + ($_ n.* 2 + (:: n.hash hash start) + (:: (list.hash super) hash inits) + (:: super hash iteration)) + + (#Recur resets) + ($_ n.* 3 + (:: (list.hash super) hash resets)) + ))) + (structure: (function-equivalence (^open "/@.")) (All [a] (-> (Equivalence a) (Equivalence (Function a)))) @@ -587,6 +687,26 @@ _ false))) +(structure: (function-hash super) + (All [a] (-> (Hash a) (Hash (Function a)))) + + (def: &equivalence + (..function-equivalence (:: super &equivalence))) + + (def: (hash value) + (case value + (#Abstraction [environment arity body]) + ($_ n.* 2 + (:: (list.hash super) hash environment) + (:: n.hash hash arity) + (:: super hash body)) + + (#Apply [abstraction arguments]) + ($_ n.* 3 + (:: super hash abstraction) + (:: (list.hash super) hash arguments)) + ))) + (structure: (control-equivalence (^open "/@.")) (All [a] (-> (Equivalence a) (Equivalence (Control a)))) @@ -602,6 +722,22 @@ _ false))) +(structure: (control-hash super) + (All [a] (-> (Hash a) (Hash (Control a)))) + + (def: &equivalence + (..control-equivalence (:: super &equivalence))) + + (def: (hash value) + (case value + (^template [<factor> <tag> <hash>] + (<tag> value) + (n.* <factor> (:: (<hash> super) hash value))) + ([2 #Branch ..branch-hash] + [3 #Loop ..loop-hash] + [5 #Function ..function-hash]) + ))) + (structure: #export equivalence (Equivalence Synthesis) @@ -623,25 +759,22 @@ (Equivalence Path) (path'-equivalence equivalence)) -## (structure: #export hash -## (Hash Synthesis) - -## (def: &equivalence ..equivalence) - -## (def: (hash value) -## (case value -## (case [reference sample] -## (^template [<tag> <hash>] -## [(<tag> value')] -## (:: <hash> hash value')) -## ([#Primitive ..primitive-hash] -## [#Structure (analysis.composite-hash hash)] -## [#Reference reference.hash] -## [#Control (control-hash hash)] -## [#Extension (extension.hash hash)]) - -## _ -## false)))) +(structure: #export hash + (Hash Synthesis) + + (def: &equivalence ..equivalence) + + (def: (hash value) + (let [recur-hash [..equivalence hash]] + (case value + (^template [<tag> <hash>] + (<tag> value) + (:: <hash> hash value)) + ([#Primitive ..primitive-hash] + [#Structure (analysis.composite-hash recur-hash)] + [#Reference reference.hash] + [#Control (..control-hash recur-hash)] + [#Extension (extension.hash recur-hash)]))))) (template: #export (!bind-top register thenP) ($_ ..path/seq diff --git a/stdlib/source/lux/tool/compiler/reference.lux b/stdlib/source/lux/tool/compiler/reference.lux index abcbe1162..e67b946b8 100644 --- a/stdlib/source/lux/tool/compiler/reference.lux +++ b/stdlib/source/lux/tool/compiler/reference.lux @@ -1,7 +1,8 @@ (.module: [lux #* [abstract - [equivalence (#+ Equivalence)]] + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] [control [pipe (#+ case>)]] [data @@ -34,6 +35,22 @@ _ false))) +(structure: #export hash + (Hash Reference) + + (def: &equivalence + ..equivalence) + + (def: (hash value) + (case value + (^template [<factor> <tag> <hash>] + (<tag> value) + ($_ n.* <factor> + (:: <hash> hash value))) + ([2 #Variable /variable.hash] + [3 #Constant name.hash]) + ))) + (template [<name> <family> <tag>] [(template: #export (<name> content) (<| <family> diff --git a/stdlib/source/lux/tool/compiler/reference/variable.lux b/stdlib/source/lux/tool/compiler/reference/variable.lux index cea605e93..0350463bd 100644 --- a/stdlib/source/lux/tool/compiler/reference/variable.lux +++ b/stdlib/source/lux/tool/compiler/reference/variable.lux @@ -35,13 +35,16 @@ (structure: #export hash (Hash Variable) - (def: &equivalence ..equivalence) + (def: &equivalence + ..equivalence) + (def: hash - (|>> (case> (#Local register) - register - - (#Foreign register) - (|> register .int (i.* -1) .nat))))) + (|>> (case> (^template [<factor> <tag>] + (<tag> register) + ($_ n.* <factor> + (:: n.hash hash register))) + ([2 #Local] + [3 #Foreign]))))) (template: #export (self) (#..Local 0)) diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index b3e55e901..50e737e98 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -34,7 +34,8 @@ ["#." region] ["#." remember] [security - ["#." policy]] + ["#." policy] + ["#." capability]] ["#." state] ["#." thread] ["#." try] @@ -81,6 +82,7 @@ Test ($_ _.and /policy.test + /capability.test )) (def: #export test diff --git a/stdlib/source/test/lux/control/security/capability.lux b/stdlib/source/test/lux/control/security/capability.lux new file mode 100644 index 000000000..b102c6a33 --- /dev/null +++ b/stdlib/source/test/lux/control/security/capability.lux @@ -0,0 +1,45 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." io (#+ IO)] + [concurrency + ["." promise]]] + [data + [number + ["n" nat]]] + [math + ["." random]]] + {1 + ["." /]}) + +(/.capability: (Can-Shift a) + (can-shift [a Nat] [a Nat])) + +(/.capability: Can-IO + (can-io [] (IO Nat))) + +(def: #export test + Test + (<| (_.covering /._) + (do random.monad + [shift random.nat + base random.nat + #let [expected (n.+ shift base)] + pass-through (random.ascii 1)] + (_.with-cover [/.Capability] + ($_ _.and + (_.cover [/.capability: /.use] + (let [capability (..can-shift (function (_ [no-op raw]) + [no-op (n.+ shift raw)])) + [untouched actual] (/.use capability [pass-through base])] + (and (is? pass-through untouched) + (n.= expected actual)))) + (wrap (let [capability (..can-io (function (_ _) (io.io expected)))] + (do promise.monad + [actual (/.use (/.async capability) [])] + (_.claim [/.async] + (n.= expected actual))))) + ))))) diff --git a/stdlib/source/test/lux/world/file.lux b/stdlib/source/test/lux/world/file.lux index 5f8d03273..0fd4d76f3 100644 --- a/stdlib/source/test/lux/world/file.lux +++ b/stdlib/source/test/lux/world/file.lux @@ -73,6 +73,7 @@ dataL (_binary.binary file-size) dataR (_binary.binary file-size) new-modified (|> r.int (:: @ map (|>> i.abs + (i.% +10,000,000,000,000) truncate-millis duration.from-millis instant.absolute)))] @@ -170,9 +171,9 @@ [file (!.use (:: /.system create-file) path) _ (!.use (:: file over-write) dataL) _ (!.use (:: file modify) new-modified) - old-modified (!.use (:: file last-modified) []) + current-modified (!.use (:: file last-modified) []) _ (!.use (:: file delete) [])] - (wrap (:: instant.equivalence = new-modified old-modified))))] + (wrap (:: instant.equivalence = new-modified current-modified))))] (_.assert "Can change the time of last modification." (try.default #0 result)))) (wrap (do promise.monad |