diff options
43 files changed, 649 insertions, 331 deletions
diff --git a/lux-js/source/program.lux b/lux-js/source/program.lux index 3232e6c82..f75a78c97 100644 --- a/lux-js/source/program.lux +++ b/lux-js/source/program.lux @@ -433,7 +433,7 @@ (for {@.old (as-is (def: (evaluate! interpreter alias input) - (-> javax/script/ScriptEngine Text _.Expression (Try Any)) + (-> javax/script/ScriptEngine Context _.Expression (Try Any)) (do try.monad [?output (javax/script/ScriptEngine::eval (_.code input) interpreter)] (case ?output @@ -443,8 +443,8 @@ #.None (exception.throw ..null-has-no-lux-representation [(#.Some input)])))) - (def: (execute! interpreter alias input) - (-> javax/script/ScriptEngine Text _.Statement (Try Any)) + (def: (execute! interpreter input) + (-> javax/script/ScriptEngine _.Statement (Try Any)) (do try.monad [?output (javax/script/ScriptEngine::eval (_.code input) interpreter)] (wrap []))) @@ -455,8 +455,8 @@ @global (_.var global)] (do try.monad [#let [definition (_.define @global input)] - _ (execute! interpreter global definition) - value (evaluate! interpreter global @global)] + _ (execute! interpreter definition) + value (evaluate! interpreter context @global)] (wrap [global value definition])))) (def: host @@ -473,12 +473,12 @@ (|> content encoding.from-utf8 try.assume (:coerce _.Statement))) (def: (re-learn context content) - (..execute! interpreter (reference.artifact context) content)) + (..execute! interpreter content)) (def: (re-load context content) (do try.monad - [_ (..execute! interpreter "" content)] - (..evaluate! interpreter "" (_.var (reference.artifact context)))))))))) + [_ (..execute! interpreter content)] + (..evaluate! interpreter context (_.var (reference.artifact context)))))))))) ) @.js @@ -493,7 +493,7 @@ (#.Some return)))) (def: (evaluate! alias input) - (-> Text _.Expression (Try Any)) + (-> Context _.Expression (Try Any)) (do try.monad [?output (host.try (..eval (_.code input)))] (case ?output @@ -503,8 +503,8 @@ #.None (exception.throw ..null-has-no-lux-representation [(#.Some input)])))) - (def: (execute! alias input) - (-> Text _.Statement (Try Any)) + (def: (execute! input) + (-> _.Statement (Try Any)) (do try.monad [?output (host.try (..eval (_.code input)))] (wrap []))) @@ -515,8 +515,8 @@ @global (_.var global)] (do try.monad [#let [definition (_.define @global input)] - _ (..execute! global definition) - value (..evaluate! global @global)] + _ (..execute! definition) + value (..evaluate! context @global)] (wrap [global value definition])))) (def: host @@ -531,12 +531,12 @@ (|> content encoding.from-utf8 try.assume (:coerce _.Statement))) (def: (re-learn context content) - (..execute! (reference.artifact context) content)) + (..execute! content)) (def: (re-load context content) (do try.monad - [_ (..execute! "" content)] - (..evaluate! "" (_.var (reference.artifact context))))))))) + [_ (..execute! content)] + (..evaluate! context (_.var (reference.artifact context))))))))) )}) (def: platform diff --git a/lux-jvm/source/luxc/lang/translation/jvm.lux b/lux-jvm/source/luxc/lang/translation/jvm.lux index cebd5e652..0ffea0e42 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm.lux @@ -104,9 +104,10 @@ ..class-path-separator (%.nat module-id) ..class-path-separator (%.nat artifact-id))) -(def: (evaluate! library loader eval-class valueI) - (-> Library java/lang/ClassLoader Text Inst (Try [Any Definition])) - (let [bytecode-name (..bytecode-name eval-class) +(def: (evaluate! library loader context valueI) + (-> Library java/lang/ClassLoader generation.Context Inst (Try [Any Definition])) + (let [eval-class (..class-name context) + bytecode-name (..bytecode-name eval-class) bytecode (def.class #jvm.V1_6 #jvm.Public jvm.noneC bytecode-name @@ -127,8 +128,8 @@ (wrap [value [eval-class bytecode]]))))) -(def: (execute! library loader temp-label [class-name class-bytecode]) - (-> Library java/lang/ClassLoader Text Definition (Try Any)) +(def: (execute! library loader [class-name class-bytecode]) + (-> Library java/lang/ClassLoader Definition (Try Any)) (io.run (do (try.with io.monad) [existing-class? (|> (atom.read library) (:: io.monad map (dictionary.contains? class-name)) @@ -141,10 +142,9 @@ (def: (define! library loader context valueI) (-> 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)] - (wrap [class-name value definition])))) + (do try.monad + [[value definition] (evaluate! library loader context valueI)] + (wrap [(..class-name context) value definition]))) (def: #export host (IO Host) @@ -152,9 +152,9 @@ loader (loader.memory library)] (: Host (structure - (def: (evaluate! temp-label valueI) + (def: (evaluate! context valueI) (:: try.monad map product.left - (..evaluate! library loader (text.replace-all " " "$" temp-label) valueI))) + (..evaluate! library loader context valueI))) (def: execute! (..execute! library loader)) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux index 31846598e..5796cc8b9 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux @@ -792,7 +792,7 @@ (<s>.tuple (<>.and <s>.text ..value))) (def: overriden-method-definition - (Parser [Environment (/.Overriden-Method Synthesis)]) + (Parser [(Environment Synthesis) (/.Overriden-Method Synthesis)]) (<s>.tuple (do <>.monad [_ (<s>.text! /.overriden-tag) ownerT ..class @@ -849,7 +849,7 @@ ))) (def: (normalize-method-body mapping) - (-> (Dictionary Variable Variable) Synthesis Synthesis) + (-> (Dictionary Synthesis Variable) Synthesis Synthesis) (function (recur body) (case body (^template [<tag>] @@ -866,7 +866,7 @@ (^ (synthesis.variable var)) (|> mapping - (dictionary.get var) + (dictionary.get body) (maybe.default var) synthesis.variable) @@ -889,10 +889,17 @@ (synthesis.loop/recur (list@map recur updatesS+)) (^ (synthesis.function/abstraction [environment arity bodyS])) - (synthesis.function/abstraction [(|> environment (list@map (function (_ local) - (|> mapping - (dictionary.get local) - (maybe.default local))))) + (synthesis.function/abstraction [(list@map (function (_ captured) + (case captured + (^ (synthesis.variable var)) + (|> mapping + (dictionary.get captured) + (maybe.default var) + synthesis.variable) + + _ + captured)) + environment) arity bodyS]) @@ -905,13 +912,13 @@ (def: $Object (type.class "java.lang.Object" (list))) (def: (anonymous-init-method env) - (-> Environment (Type Method)) + (-> (Environment Synthesis) (Type Method)) (type.method [(list.repeat (list.size env) $Object) type.void (list)])) (def: (with-anonymous-init class env super-class inputsTI) - (-> (Type Class) Environment (Type Class) (List (Typed Inst)) Def) + (-> (Type Class) (Environment Synthesis) (Type Class) (List (Typed Inst)) Def) (let [store-capturedI (|> env list.size list.indices @@ -927,10 +934,10 @@ store-capturedI _.RETURN)))) -(def: (anonymous-instance archive class env) - (-> Archive (Type Class) Environment (Operation Inst)) +(def: (anonymous-instance generate archive class env) + (-> Phase Archive (Type Class) (Environment Synthesis) (Operation Inst)) (do {@ phase.monad} - [captureI+ (monad.map @ (///reference.variable archive) env)] + [captureI+ (monad.map @ (generate archive) env)] (wrap (|>> (_.NEW class) _.DUP (_.fuse captureI+) @@ -987,14 +994,14 @@ ## Combine them. list@join ## Remove duplicates. - (set.from-list variable.hash) + (set.from-list synthesis.hash) set.to-list) global-mapping (|> total-environment ## Give them names as "foreign" variables. list.enumerate (list@map (function (_ [id capture]) [capture (#variable.Foreign id)])) - (dictionary.from-list variable.hash)) + (dictionary.from-list synthesis.hash)) normalized-methods (list@map (function (_ [environment [ownerT name strict-fp? annotations vars @@ -1003,11 +1010,11 @@ (let [local-mapping (|> environment list.enumerate (list@map (function (_ [foreign-id capture]) - [(#variable.Foreign foreign-id) + [(synthesis.variable/foreign foreign-id) (|> global-mapping (dictionary.get capture) maybe.assume)])) - (dictionary.from-list variable.hash))] + (dictionary.from-list synthesis.hash))] [ownerT name strict-fp? annotations vars self-name arguments returnT exceptionsT @@ -1032,15 +1039,16 @@ exceptionsT]) (|>> bodyG (returnI returnT))))))) (:: @ map _def.fuse)) - _ (generation.save! true ["" (%.nat artifact-id)] - [anonymous-class-name - (_def.class #$.V1_6 #$.Public $.finalC - anonymous-class-name (list) - super-class super-interfaces - (|>> (///function.with-environment total-environment) - (..with-anonymous-init class total-environment super-class inputsTI) - method-definitions))])] - (anonymous-instance archive class total-environment)))])) + #let [directive [anonymous-class-name + (_def.class #$.V1_6 #$.Public $.finalC + anonymous-class-name (list) + super-class super-interfaces + (|>> (///function.with-environment total-environment) + (..with-anonymous-init class total-environment super-class inputsTI) + method-definitions))]] + _ (generation.execute! directive) + _ (generation.save! (%.nat artifact-id) directive)] + (..anonymous-instance generate archive class total-environment)))])) (def: bundle::class Bundle diff --git a/lux-jvm/source/luxc/lang/translation/jvm/function.lux b/lux-jvm/source/luxc/lang/translation/jvm/function.lux index bfa11f1c2..2a792612c 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/function.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/function.lux @@ -1,7 +1,8 @@ (.module: [lux (#- Type function) [abstract - ["." monad (#+ do)]] + ["." monad (#+ do)] + ["." enum]] [control [pipe (#+ when> new>)] ["." function]] @@ -48,11 +49,11 @@ (n.> 1 arity)) (def: (captured-args env) - (-> Environment (List (Type Value))) + (-> (Environment Synthesis) (List (Type Value))) (list.repeat (list.size env) //.$Value)) (def: (init-method env arity) - (-> Environment Arity (Type Method)) + (-> (Environment Synthesis) Arity (Type Method)) (if (poly-arg? arity) (type.method [(list.concat (list (captured-args env) (list type.int) @@ -76,7 +77,7 @@ (def: (inputsI start amount) (-> Register Nat Inst) - (|> (list.n/range start (n.+ start (dec amount))) + (|> (enum.range n.enum start (n.+ start (dec amount))) (list@map _.ALOAD) _.fuse)) @@ -102,10 +103,10 @@ (list.repeat amount) _.fuse)) -(def: (instance archive class arity env) - (-> Archive (Type Class) Arity Environment (Operation Inst)) +(def: (instance generate archive class arity env) + (-> Phase Archive (Type Class) Arity (Environment Synthesis) (Operation Inst)) (do {@ phase.monad} - [captureI+ (monad.map @ (reference.variable archive) env) + [captureI+ (monad.map @ (generate archive) env) #let [argsI (if (poly-arg? arity) (|> (nullsI (dec arity)) (list (_.int +0)) @@ -122,13 +123,13 @@ (type.method [(list) return (list)])) (def: (with-reset class arity env) - (-> (Type Class) Arity Environment Def) + (-> (Type Class) Arity (Environment Synthesis) Def) (def.method #$.Public $.noneM "reset" (reset-method class) (if (poly-arg? arity) (let [env-size (list.size env) captureI (|> (case env-size 0 (list) - _ (list.n/range 0 (dec env-size))) + _ (enum.range n.enum 0 (dec env-size))) (list@map (.function (_ source) (|>> (_.ALOAD 0) (_.GETFIELD class (reference.foreign-name source) //.$Value)))) @@ -164,20 +165,20 @@ (_.INVOKESPECIAL //.$Function "<init>" function-init-method)))) (def: (with-init class env arity) - (-> (Type Class) Environment Arity Def) + (-> (Type Class) (Environment Synthesis) Arity Def) (let [env-size (list.size env) offset-partial (: (-> Nat Nat) (|>> inc (n.+ env-size))) store-capturedI (|> (case env-size 0 (list) - _ (list.n/range 0 (dec env-size))) + _ (enum.range n.enum 0 (dec env-size))) (list@map (.function (_ register) (|>> (_.ALOAD 0) (_.ALOAD (inc register)) (_.PUTFIELD class (reference.foreign-name register) //.$Value)))) _.fuse) store-partialI (if (poly-arg? arity) - (|> (list.n/range 0 (n.- 2 arity)) + (|> (enum.range n.enum 0 (n.- 2 arity)) (list@map (.function (_ idx) (let [register (offset-partial idx)] (|>> (_.ALOAD 0) @@ -193,17 +194,17 @@ _.RETURN)))) (def: (with-apply class env function-arity @begin bodyI apply-arity) - (-> (Type Class) Environment Arity Label Inst Arity + (-> (Type Class) (Environment Synthesis) Arity Label Inst Arity Def) (let [num-partials (dec function-arity) @default ($.new-label []) @labels (list@map $.new-label (list.repeat num-partials [])) over-extent (|> (.int function-arity) (i.- (.int apply-arity))) casesI (|> (list@compose @labels (list @default)) - (list.zip2 (list.n/range 0 num-partials)) + (list.zip2 (enum.range n.enum 0 num-partials)) (list@map (.function (_ [stage @label]) (let [load-partialsI (if (n.> 0 stage) - (|> (list.n/range 0 (dec stage)) + (|> (enum.range n.enum 0 (dec stage)) (list@map (|>> reference.partial-name (load-fieldI class))) _.fuse) function.identity)] @@ -233,7 +234,7 @@ (let [env-size (list.size env) load-capturedI (|> (case env-size 0 (list) - _ (list.n/range 0 (dec env-size))) + _ (enum.range n.enum 0 (dec env-size))) (list@map (|>> reference.foreign-name (load-fieldI class))) _.fuse)] (|>> (_.label @label) @@ -257,7 +258,7 @@ )))) (def: #export with-environment - (-> Environment Def) + (-> (Environment Synthesis) Def) (|>> list.enumerate (list@map (.function (_ [env-idx env-source]) (def.field #$.Private $.finalF (reference.foreign-name env-idx) //.$Value))) @@ -266,20 +267,20 @@ (def: (with-partial arity) (-> Arity Def) (if (poly-arg? arity) - (|> (list.n/range 0 (n.- 2 arity)) + (|> (enum.range n.enum 0 (n.- 2 arity)) (list@map (.function (_ idx) (def.field #$.Private $.finalF (reference.partial-name idx) //.$Value))) def.fuse) function.identity)) -(def: #export (with-function archive @begin class env arity bodyI) - (-> Archive Label Text Environment Arity Inst +(def: #export (with-function generate archive @begin class env arity bodyI) + (-> Phase Archive Label Text (Environment Synthesis) Arity Inst (Operation [Def Inst])) (let [classD (type.class class (list)) applyD (: Def (if (poly-arg? arity) (|> (n.min arity //runtime.num-apply-variants) - (list.n/range 1) + (enum.range n.enum 1) (list@map (with-apply classD env arity @begin bodyI)) (list& (with-implementation arity @begin bodyI)) def.fuse) @@ -296,7 +297,7 @@ applyD ))] (do phase.monad - [instanceI (instance archive classD arity env)] + [instanceI (..instance generate archive classD arity env)] (wrap [functionD instanceI])))) (def: #export (function generate archive [env arity bodyS]) @@ -307,13 +308,14 @@ (generation.with-anchor [@begin 1] (generate archive bodyS))) #let [function-class (//.class-name function-context)] - [functionD instanceI] (with-function archive @begin function-class env arity bodyI) - _ (generation.save! true ["" (%.nat (product.right function-context))] - [function-class - (def.class #$.V1_6 #$.Public $.finalC - function-class (list) - //.$Function (list) - functionD)])] + [functionD instanceI] (..with-function generate archive @begin function-class env arity bodyI) + #let [directive [function-class + (def.class #$.V1_6 #$.Public $.finalC + function-class (list) + //.$Function (list) + functionD)]] + _ (generation.execute! directive) + _ (generation.save! (%.nat (product.right function-context)) directive)] (wrap instanceI))) (def: #export (call generate archive [functionS argsS]) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux index 1cad5569f..e7a37584e 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux @@ -1,7 +1,8 @@ (.module: [lux (#- Type) [abstract - [monad (#+ do)]] + [monad (#+ do)] + ["." enum]] [data [binary (#+ Binary)] ["." product] @@ -9,7 +10,9 @@ ["%" format (#+ format)]] [collection ["." list ("#@." functor)] - ["." row]]] + ["." row]] + [number + ["n" nat]]] ["." math] [target [jvm @@ -339,18 +342,18 @@ frac-methods pm-methods io-methods)) - payload ["0" bytecode]] + directive [runtime-class bytecode]] (do phase.monad - [_ (generation.execute! runtime-class [runtime-class bytecode]) - _ (generation.save! false ["" "0"] payload)] - (wrap payload)))) + [_ (generation.execute! directive) + _ (generation.save! "0" directive)] + (wrap ["0" bytecode])))) (def: translate-function (Operation [Text Binary]) - (let [applyI (|> (list.n/range 2 num-apply-variants) + (let [applyI (|> (enum.range n.enum 2 num-apply-variants) (list@map (function (_ arity) ($d.method #$.Public $.noneM apply-method (apply-signature arity) - (let [preI (|> (list.n/range 0 (dec arity)) + (let [preI (|> (enum.range n.enum 0 (dec arity)) (list@map _.ALOAD) _.fuse)] (|>> preI @@ -373,11 +376,11 @@ (_.PUTFIELD //.$Function partials-field type.int) _.RETURN)) applyI)) - payload ["1" bytecode]] + directive [function-class bytecode]] (do phase.monad - [_ (generation.execute! function-class [function-class bytecode]) - _ (generation.save! false ["" "1"] payload)] - (wrap payload)))) + [_ (generation.execute! directive) + _ (generation.save! "1" directive)] + (wrap ["1" bytecode])))) (def: #export translate (Operation [Registry Output]) diff --git a/lux-jvm/source/program.lux b/lux-jvm/source/program.lux index 2dcbd5471..1114dd3b6 100644 --- a/lux-jvm/source/program.lux +++ b/lux-jvm/source/program.lux @@ -168,6 +168,7 @@ translation.bundle (directive.bundle ..extender) (jvm/program.program jvm/runtime.class-name) + [_.Anchor _.Inst _.Definition] ..extender service [packager.package 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 |