diff options
Diffstat (limited to '')
11 files changed, 971 insertions, 326 deletions
diff --git a/stdlib/source/lux/control/io.lux b/stdlib/source/lux/control/io.lux index 533e321b9..ed28b338e 100644 --- a/stdlib/source/lux/control/io.lux +++ b/stdlib/source/lux/control/io.lux @@ -17,9 +17,9 @@ {#.doc "A type that represents synchronous, effectful computations that may interact with the outside world."} (-> Any a) - (def: (label thunk) + (def: label (All [a] (-> (-> Any a) (IO a))) - (:abstraction thunk)) + (|>> :abstraction)) (template: (!io computation) (:abstraction (template.with-locals [g!func g!arg] @@ -49,17 +49,23 @@ (All [a] (-> (IO a) a)) (|>> !run)) - (structure: #export functor (Functor IO) + (structure: #export functor + (Functor IO) + (def: (map f) (|>> !run f !io))) - (structure: #export apply (Apply IO) + (structure: #export apply + (Apply IO) + (def: &functor ..functor) (def: (apply ff fa) (!io ((!run ff) (!run fa))))) - (structure: #export monad (Monad IO) + (structure: #export monad + (Monad IO) + (def: &functor ..functor) (def: wrap (|>> !io)) diff --git a/stdlib/source/lux/control/parser/binary.lux b/stdlib/source/lux/control/parser/binary.lux index 3dc061940..ed698ccd1 100644 --- a/stdlib/source/lux/control/parser/binary.lux +++ b/stdlib/source/lux/control/parser/binary.lux @@ -50,6 +50,11 @@ (function (_ (^@ input [offset data])) (#try.Success [input (n.= offset (/.size data))]))) +(def: #export offset + (Parser Offset) + (function (_ (^@ input [offset data])) + (#try.Success [input offset]))) + (def: #export remaining (Parser Nat) (function (_ (^@ input [offset data])) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux index c9bc95612..71009473a 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux @@ -103,7 +103,7 @@ _ false))) -(structure: (composite-equivalence (^open "/@.")) +(structure: #export (composite-equivalence (^open "/@.")) (All [a] (-> (Equivalence a) (Equivalence (Composite a)))) (def: (= reference sample) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux index e34c78f71..890722aeb 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux @@ -3,7 +3,8 @@ [abstract ["." monad (#+ do)]] [control - ["ex" exception (#+ exception:)]] + [pipe (#+ case>)] + ["." exception (#+ exception:)]] [data ["." maybe] ["." text @@ -22,10 +23,11 @@ ["." phase ("#@." monad)]]]]) (exception: #export (cannot-find-foreign-variable-in-environment {foreign Register} {environment Environment}) - (ex.report ["Foreign" (%.nat foreign)] - ["Environment" (|> environment - (list@map ////reference/variable.format) - (text.join-with " "))])) + (exception.report + ["Foreign" (%.nat foreign)] + ["Environment" (|> environment + (list@map ////reference/variable.format) + (text.join-with " "))])) (def: arity-arguments (-> Arity (List Synthesis)) @@ -46,15 +48,15 @@ (let [[funcA argsA] (////analysis.application exprA)] (do {@ phase.monad} [funcS (phase archive funcA) - argsS (monad.map @ (phase archive) argsA) - ## locals /.locals - ] + argsS (monad.map @ (phase archive) argsA)] (with-expansions [<apply> (as-is (/.function/apply [funcS argsS]))] (case funcS - ## (^ (/.function/abstraction functionS)) - ## (wrap (|> functionS - ## (//loop.loop (get@ #/.environment functionS) locals argsS) - ## (maybe.default <apply>))) + (^ (/.function/abstraction functionS)) + (do @ + [locals /.locals] + (wrap (|> functionS + (//loop.optimization locals argsS) + (maybe.default <apply>)))) (^ (/.function/apply [funcS' argsS'])) (wrap (/.function/apply [funcS' (list@compose argsS' argsS)])) @@ -69,7 +71,7 @@ (phase@wrap aliased) #.None - (phase.throw cannot-find-foreign-variable-in-environment [register environment]))) + (phase.throw ..cannot-find-foreign-variable-in-environment [register environment]))) (def: (grow-path grow path) (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path)) @@ -172,7 +174,7 @@ (do {@ phase.monad} [initsS+' (monad.map @ (grow environment) initsS+) iterationS' (grow environment iterationS)] - (wrap (/.loop/scope [start initsS+' iterationS']))) + (wrap (/.loop/scope [(inc start) initsS+' iterationS']))) (#/.Recur argumentsS+) (|> argumentsS+ @@ -209,7 +211,8 @@ (def: #export (abstraction phase environment archive bodyA) (-> Phase Environment Phase) (do {@ phase.monad} - [bodyS (phase archive bodyA)] + [bodyS (/.with-locals 2 + (phase archive bodyA))] (case bodyS (^ (/.function/abstraction [env' down-arity' bodyS'])) (|> bodyS' diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux index 5aa644e18..b4a43ce23 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux @@ -1,303 +1,171 @@ (.module: - [lux (#- loop) + [lux #* [abstract ["." monad (#+ do)]] - [control - ["p" parser]] [data ["." maybe ("#@." monad)] [number ["n" nat]] [collection - ["." list ("#@." functor)]]] - [macro - ["." code] - ["." syntax]]] - ["." /// #_ - ## TODO: Remove the 'extension' import ASAP. - ["#." extension] - [// - ["#." analysis (#+ Environment)] - ["/" synthesis (#+ Path Abstraction Synthesis)] - [/// - ["#." reference - ["#/." variable (#+ Register Variable)]]]]]) + ["." list]]]] + [//// + ["." analysis (#+ Environment)] + ["/" synthesis (#+ Path Abstraction Synthesis)] + [/// + [arity (#+ Arity)] + ["." reference + ["." variable (#+ Register Variable)]]]]) (type: #export (Transform a) (-> a (Maybe a))) -(def: (some? maybe) - (All [a] (-> (Maybe a) Bit)) - (case maybe - (#.Some _) #1 - #.None #0)) +(def: #export (register-optimization offset) + (-> Register (-> Register Register)) + (|>> dec (n.+ offset))) -(template: #export (self) - (#/.Reference (///reference.local 0))) +(def: (variable-optimization offset environment variable) + (-> Register Environment (Transform Variable)) + (case variable + (^ (variable.self)) + #.None + + (#variable.Foreign register) + (list.nth register environment) -(template: (recursive-apply args) - (#/.Apply (self) args)) + (#variable.Local register) + (#.Some (#variable.Local (register-optimization offset register))))) -(def: improper #0) -(def: proper #1) - -(def: (proper? exprS) - (-> Synthesis Bit) - (case exprS - (^ (self)) - ..improper - - (#/.Structure structure) - (case structure - (#///analysis.Variant variantS) - (proper? (get@ #///analysis.value variantS)) - - (#///analysis.Tuple membersS+) - (list.every? proper? membersS+)) - - (#/.Control controlS) - (case controlS - (#/.Branch branchS) - (case branchS - (#/.Case inputS pathS) - (and (proper? inputS) - (.loop [pathS pathS] - (case pathS - (^or (#/.Alt leftS rightS) (#/.Seq leftS rightS)) - (and (recur leftS) (recur rightS)) - - (#/.Then bodyS) - (proper? bodyS) - - _ - ..proper))) - - (#/.Let inputS register bodyS) - (and (proper? inputS) - (proper? bodyS)) - - (#/.If inputS thenS elseS) - (and (proper? inputS) - (proper? thenS) - (proper? elseS)) - - (#/.Get members inputS) - (proper? inputS)) - - (#/.Loop loopS) - (case loopS - (#/.Scope scopeS) - (and (list.every? proper? (get@ #/.inits scopeS)) - (proper? (get@ #/.iteration scopeS))) - - (#/.Recur argsS) - (list.every? proper? argsS)) - - (#/.Function functionS) - (case functionS - (#/.Abstraction environment arity bodyS) - (list.every? ///reference/variable.self? environment) - - (#/.Apply funcS argsS) - (and (proper? funcS) - (list.every? proper? argsS)))) - - (#/.Extension [name argsS]) - (list.every? proper? argsS) - - _ - ..proper)) - -(def: (path-recursion synthesis-recursion) - (-> (Transform Synthesis) (Transform Path)) - (function (recur pathS) - (case pathS - (#/.Alt leftS rightS) - (let [leftS' (recur leftS) - rightS' (recur rightS)] - (if (or (some? leftS') - (some? rightS')) - (#.Some (#/.Alt (maybe.default leftS leftS') - (maybe.default rightS rightS'))) - #.None)) - - (#/.Seq leftS rightS) - (maybe@map (|>> (#/.Seq leftS)) (recur rightS)) - - (#/.Then bodyS) - (maybe@map (|>> #/.Then) (synthesis-recursion bodyS)) - - _ - #.None))) - -(def: #export (recursion arity) - (-> Nat (Transform Synthesis)) - (function (recur exprS) - (case exprS - (#/.Control controlS) - (case controlS - (#/.Branch branchS) - (case branchS - (#/.Case inputS pathS) - (|> pathS - (path-recursion recur) - (maybe@map (|>> (#/.Case inputS) #/.Branch #/.Control))) - - (#/.Let inputS register bodyS) - (maybe@map (|>> (#/.Let inputS register) #/.Branch #/.Control) - (recur bodyS)) - - (#/.If inputS thenS elseS) - (let [thenS' (recur thenS) - elseS' (recur elseS)] - (if (or (some? thenS') - (some? elseS')) - (#.Some (|> (#/.If inputS - (maybe.default thenS thenS') - (maybe.default elseS elseS')) - #/.Branch #/.Control)) - #.None)) - - (#/.Get members inputS) - #.None) - - (^ (#/.Function (recursive-apply argsS))) - (if (n.= arity (list.size argsS)) - (#.Some (|> argsS #/.Recur #/.Loop #/.Control)) - #.None) - - _ - #.None) - - _ - #.None))) - -(def: (resolve environment) - (-> Environment (Transform Variable)) - (function (_ variable) - (case variable - (#///reference/variable.Foreign register) - (list.nth register environment) - - _ - (#.Some variable)))) - -(def: (adjust-path adjust-synthesis offset) +(def: (path-optimization body-optimization offset) (-> (Transform Synthesis) Register (Transform Path)) - (function (recur pathS) - (case pathS + (function (recur path) + (case path (#/.Bind register) - (#.Some (#/.Bind (n.+ offset register))) + (#.Some (#/.Bind (register-optimization offset register))) (^template [<tag>] - (<tag> leftS rightS) + (<tag> left right) (do maybe.monad - [leftS' (recur leftS) - rightS' (recur rightS)] - (wrap (<tag> leftS' rightS')))) + [left' (recur left) + right' (recur right)] + (wrap (<tag> left' right')))) ([#/.Alt] [#/.Seq]) - (#/.Then bodyS) - (|> bodyS adjust-synthesis (maybe@map (|>> #/.Then))) + (#/.Then body) + (|> body + body-optimization + (maybe@map (|>> #/.Then))) _ - (#.Some pathS)))) - -(def: (adjust scope-environment offset) - (-> Environment Register (Transform Synthesis)) - (function (recur exprS) - (case exprS - (#/.Structure structureS) - (case structureS - (#///analysis.Variant variantS) + (#.Some path)))) + +(def: (body-optimization offset scope-environment arity expr) + (-> Register Environment Arity (Transform Synthesis)) + (loop [return? true + expr expr] + (case expr + (#/.Primitive _) + (#.Some expr) + + (#/.Structure structure) + (case structure + (#analysis.Variant variant) (do maybe.monad - [valueS' (|> variantS (get@ #///analysis.value) recur)] - (wrap (|> variantS - (set@ #///analysis.value valueS') - #///analysis.Variant - #/.Structure))) + [value' (|> variant (get@ #analysis.value) (recur false))] + (wrap (|> variant + (set@ #analysis.value value') + /.variant))) - (#///analysis.Tuple membersS+) - (|> membersS+ - (monad.map maybe.monad recur) - (maybe@map (|>> #///analysis.Tuple #/.Structure)))) + (#analysis.Tuple tuple) + (|> tuple + (monad.map maybe.monad (recur false)) + (maybe@map (|>> /.tuple)))) (#/.Reference reference) (case reference - (^ (///reference.constant constant)) - (#.Some exprS) + (^ (#reference.Variable (variable.self))) + #.None + + (^ (reference.constant constant)) + (#.Some expr) - (^ (///reference.local register)) - (#.Some (#/.Reference (///reference.local (n.+ offset register)))) + (^ (reference.local register)) + (#.Some (#/.Reference (reference.local (register-optimization offset register)))) - (^ (///reference.foreign register)) + (^ (reference.foreign register)) (|> scope-environment (list.nth register) - (maybe@map (|>> #///reference.Variable #/.Reference)))) + (maybe@map (|>> #reference.Variable #/.Reference)))) - (^ (/.branch/case [inputS pathS])) + (^ (/.branch/case [input path])) (do maybe.monad - [inputS' (recur inputS) - pathS' (adjust-path recur offset pathS)] - (wrap (|> pathS' [inputS'] /.branch/case))) + [input' (recur false input) + path' (path-optimization (recur return?) offset path)] + (wrap (|> path' [input'] /.branch/case))) - (^ (/.branch/let [inputS register bodyS])) + (^ (/.branch/let [input register body])) (do maybe.monad - [inputS' (recur inputS) - bodyS' (recur bodyS)] - (wrap (/.branch/let [inputS' register bodyS']))) + [input' (recur false input) + body' (recur return? body)] + (wrap (/.branch/let [input' (register-optimization offset register) body']))) - (^ (/.branch/if [inputS thenS elseS])) + (^ (/.branch/if [input then else])) (do maybe.monad - [inputS' (recur inputS) - thenS' (recur thenS) - elseS' (recur elseS)] - (wrap (/.branch/if [inputS' thenS' elseS']))) + [input' (recur false input) + then' (recur return? then) + else' (recur return? else)] + (wrap (/.branch/if [input' then' else']))) - (^ (/.loop/scope scopeS)) + (^ (/.branch/get [path record])) (do maybe.monad - [inits' (|> scopeS + [record (recur false record)] + (wrap (/.branch/get [path record]))) + + (^ (/.loop/scope scope)) + (do {@ maybe.monad} + [inits' (|> scope (get@ #/.inits) - (monad.map maybe.monad recur)) - iteration' (recur (get@ #/.iteration scopeS))] - (wrap (/.loop/scope {#/.start (|> scopeS (get@ #/.start) (n.+ offset)) + (monad.map @ (recur false))) + iteration' (recur return? (get@ #/.iteration scope))] + (wrap (/.loop/scope {#/.start (|> scope (get@ #/.start) (register-optimization offset)) #/.inits inits' #/.iteration iteration'}))) - (^ (/.loop/recur argsS)) - (|> argsS - (monad.map maybe.monad recur) + (^ (/.loop/recur args)) + (|> args + (monad.map maybe.monad (recur false)) (maybe@map (|>> /.loop/recur))) - - (^ (/.function/abstraction [environment arity bodyS])) - (do maybe.monad - [environment' (monad.map maybe.monad - (resolve scope-environment) + (^ (/.function/abstraction [environment arity body])) + (do {@ maybe.monad} + [environment' (monad.map @ (variable-optimization offset scope-environment) environment)] - (wrap (/.function/abstraction [environment' arity bodyS]))) + (wrap (/.function/abstraction [environment' arity body]))) - (^ (/.function/apply [function arguments])) - (do maybe.monad - [function' (recur function) - arguments' (monad.map maybe.monad recur arguments)] - (wrap (/.function/apply [function' arguments']))) - - (#/.Extension [name argsS]) - (|> argsS - (monad.map maybe.monad recur) - (maybe@map (|>> [name] #/.Extension))) - - _ - (#.Some exprS)))) - -(def: #export (loop environment num-locals inits functionS) - (-> Environment Nat (List Synthesis) Abstraction (Maybe Synthesis)) - (let [bodyS (get@ #/.body functionS)] - (if (and (n.= (list.size inits) - (get@ #/.arity functionS)) - (proper? bodyS)) - (|> bodyS - (adjust environment num-locals) - (maybe@map (|>> [(inc num-locals) inits] /.loop/scope))) - #.None))) + (^ (/.function/apply [abstraction arguments])) + (do {! maybe.monad} + [arguments' (monad.map maybe.monad (recur false) arguments)] + (case abstraction + (^ (#/.Reference (#reference.Variable (variable.self)))) + (if (and return? + (n.= arity (list.size arguments))) + (wrap (/.loop/recur arguments')) + #.None) + + _ + (do ! + [abstraction' (recur false abstraction)] + (wrap (/.function/apply [abstraction' arguments']))))) + + (#/.Extension [name args]) + (|> args + (monad.map maybe.monad (recur false)) + (maybe@map (|>> [name] #/.Extension)))))) + +(def: #export (optimization offset inits functionS) + (-> Register (List Synthesis) Abstraction (Maybe Synthesis)) + (if (n.= (get@ #/.arity functionS) + (list.size inits)) + (|> (get@ #/.body functionS) + (body-optimization offset (get@ #/.environment functionS) (get@ #/.arity functionS)) + (maybe@map (|>> [offset inits] /.loop/scope))) + #.None)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux index a88d986fc..06f84d90d 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux @@ -4,8 +4,9 @@ [monad (#+ do)] [equivalence (#+ Equivalence)]] [control - ["ex" exception (#+ exception:)]] + ["." exception (#+ exception:)]] [data + ["." sum] ["." bit ("#@." equivalence)] ["." text ("#@." equivalence) ["%" format (#+ Format format)]] @@ -16,15 +17,15 @@ [collection ["." list ("#@." functor)] ["." dictionary (#+ Dictionary)]]]] - ["." // #_ - ["#." analysis (#+ Environment Composite Analysis)] + [// + ["." analysis (#+ Environment Composite Analysis)] [phase ["." extension (#+ Extension)]] [/// [arity (#+ Arity)] - ["#." reference (#+ Reference) - ["#/." variable (#+ Register Variable)]] - ["#." phase]]]) + ["." phase] + ["." reference (#+ Reference) + ["." variable (#+ Register Variable)]]]]) (type: #export Resolver (Dictionary Variable Variable)) @@ -33,7 +34,7 @@ (def: #export fresh-resolver Resolver - (dictionary.new //reference/variable.hash)) + (dictionary.new variable.hash)) (def: #export init State @@ -202,7 +203,7 @@ (def: #export with-new-local (All [a] (-> (Operation a) (Operation a))) - (<<| (do //phase.monad + (<<| (do phase.monad [locals ..locals]) (..with-locals (inc locals)))) @@ -222,8 +223,8 @@ <tag> content))] - [variant #//analysis.Variant] - [tuple #//analysis.Tuple] + [variant #analysis.Variant] + [tuple #analysis.Tuple] ) (template [<name> <tag>] @@ -232,10 +233,10 @@ <tag> content))] - [variable //reference.variable] - [constant //reference.constant] - [variable/local //reference.local] - [variable/foreign //reference.foreign] + [variable reference.variable] + [constant reference.constant] + [variable/local reference.local] + [variable/foreign reference.foreign] ) (template [<name> <family> <tag>] @@ -327,36 +328,35 @@ (#Structure structure) (case structure - (#//analysis.Variant [lefts right? content]) + (#analysis.Variant [lefts right? content]) (|> (%synthesis content) (format (%.nat lefts) " " (%.bit right?) " ") (text.enclose ["(" ")"])) - (#//analysis.Tuple members) + (#analysis.Tuple members) (|> members (list@map %synthesis) (text.join-with " ") (text.enclose ["[" "]"]))) (#Reference reference) - (//reference.format reference) + (reference.format reference) (#Control control) (case control (#Function function) (case function (#Abstraction [environment arity body]) - (|> (%synthesis body) - (format (%.nat arity) " ") - (format (|> environment - (list@map //reference/variable.format) - (text.join-with " ") - (text.enclose ["[" "]"])) - " ") - (text.enclose ["(" ")"])) + (let [environment' (|> environment + (list@map variable.format) + (text.join-with " ") + (text.enclose ["[" "]"]))] + (|> (format environment' " " (%.nat arity) " " (%synthesis body)) + (text.enclose ["(#function " ")"]))) (#Apply func args) - (|> (list@map %synthesis args) + (|> args + (list@map %synthesis) (text.join-with " ") (format (%synthesis func) " ") (text.enclose ["(" ")"]))) @@ -364,7 +364,7 @@ (#Branch branch) (case branch (#Let input register body) - (|> (format (%synthesis input) " " (%.nat register) " " (%synthesis body)) + (|> (format (%.nat register) " " (%synthesis input) " " (%synthesis body)) (text.enclose ["(#let " ")"])) (#If test then else) @@ -381,9 +381,22 @@ (|> (format (%synthesis input) " " (%path' %synthesis path)) (text.enclose ["(#case " ")"]))) - ## (#Loop loop) - _ - "???") + (#Loop loop) + (case loop + (#Scope scope) + (|> (format (%.nat (get@ #start scope)) + " " (|> (get@ #inits scope) + (list@map %synthesis) + (text.join-with " ") + (text.enclose ["[" "]"])) + " " (%synthesis (get@ #iteration scope))) + (text.enclose ["(#loop " ")"])) + + (#Recur args) + (|> args + (list@map %synthesis) + (text.join-with " ") + (text.enclose ["(#recur " ")"])))) (#Extension [name args]) (|> (list@map %synthesis args) @@ -395,7 +408,9 @@ (Format Path) (%path' %synthesis)) -(structure: #export primitive-equivalence (Equivalence Primitive) +(structure: #export primitive-equivalence + (Equivalence Primitive) + (def: (= reference sample) (case [reference sample] (^template [<tag> <eq> <format>] @@ -411,27 +426,29 @@ _ false))) -(structure: #export access-equivalence (Equivalence Access) +(def: side-equivalence + (Equivalence Side) + (sum.equivalence n.equivalence n.equivalence)) + +(def: member-equivalence + (Equivalence Member) + (sum.equivalence n.equivalence n.equivalence)) + +(structure: #export access-equivalence + (Equivalence Access) + (def: (= reference sample) (case [reference sample] - (^template [<tag>] - [(<tag> reference') (<tag> sample')] - (case [reference' sample'] - (^template [<side>] - [(<side> reference'') (<side> sample'')] - (n.= reference'' sample'')) - ([#.Left] - [#.Right]) - - _ - false)) - ([#Side] - [#Member]) + (^template [<tag> <equivalence>] + [(<tag> reference) (<tag> sample)] + (:: <equivalence> = reference sample)) + ([#Side ..side-equivalence] + [#Member ..member-equivalence]) _ false))) -(structure: #export (path'-equivalence Equivalence<a>) +(structure: #export (path'-equivalence equivalence) (All [a] (-> (Equivalence a) (Equivalence (Path' a)))) (def: (= reference sample) @@ -444,7 +461,7 @@ (:: <equivalence> = reference' sample')) ([#Test primitive-equivalence] [#Access access-equivalence] - [#Then Equivalence<a>]) + [#Then equivalence]) [(#Bind reference') (#Bind sample')] (n.= reference' sample') @@ -459,13 +476,100 @@ _ false))) -(structure: #export equivalence (Equivalence Synthesis) +(structure: (branch-equivalence (^open "/@.")) + (All [a] (-> (Equivalence a) (Equivalence (Branch a)))) + + (def: (= reference sample) + (case [reference sample] + [(#Let [reference-input reference-register reference-body]) + (#Let [sample-input sample-register sample-body])] + (and (/@= reference-input sample-input) + (n.= reference-register sample-register) + (/@= reference-body sample-body)) + + [(#If [reference-test reference-then reference-else]) + (#If [sample-test sample-then sample-else])] + (and (/@= reference-test sample-test) + (/@= reference-then sample-then) + (/@= reference-else sample-else)) + + [(#Get [reference-path reference-record]) + (#Get [sample-path sample-record])] + (and (:: (list.equivalence ..member-equivalence) = reference-path sample-path) + (/@= reference-record sample-record)) + + [(#Case [reference-input reference-path]) + (#Case [sample-input sample-path])] + (and (/@= reference-input sample-input) + (:: (path'-equivalence /@=) = reference-path sample-path)) + + _ + false))) + +(structure: (loop-equivalence (^open "/@.")) + (All [a] (-> (Equivalence a) (Equivalence (Loop a)))) + + (def: (= reference sample) + (case [reference sample] + [(#Scope [reference-start reference-inits reference-iteration]) + (#Scope [sample-start sample-inits sample-iteration])] + (and (n.= reference-start sample-start) + (:: (list.equivalence /@=) = reference-inits sample-inits) + (/@= reference-iteration sample-iteration)) + + [(#Recur reference) (#Recur sample)] + (:: (list.equivalence /@=) = reference sample) + + _ + false))) + +(structure: (function-equivalence (^open "/@.")) + (All [a] (-> (Equivalence a) (Equivalence (Function a)))) + + (def: (= reference sample) + (case [reference sample] + [(#Abstraction [reference-environment reference-arity reference-body]) + (#Abstraction [sample-environment sample-arity sample-body])] + (and (:: (list.equivalence variable.equivalence) = reference-environment sample-environment) + (n.= reference-arity sample-arity) + (/@= reference-body sample-body)) + + [(#Apply [reference-abstraction reference-arguments]) + (#Apply [sample-abstraction sample-arguments])] + (and (/@= reference-abstraction sample-abstraction) + (:: (list.equivalence /@=) = reference-arguments sample-arguments)) + + _ + false))) + +(structure: (control-equivalence (^open "/@.")) + (All [a] (-> (Equivalence a) (Equivalence (Control a)))) + + (def: (= reference sample) + (case [reference sample] + (^template [<tag> <equivalence>] + [(<tag> reference) (<tag> sample)] + (:: (<equivalence> /@=) = reference sample)) + ([#Branch ..branch-equivalence] + [#Loop ..loop-equivalence] + [#Function ..function-equivalence]) + + _ + false))) + +(structure: #export equivalence + (Equivalence Synthesis) + (def: (= reference sample) (case [reference sample] (^template [<tag> <equivalence>] [(<tag> reference') (<tag> sample')] (:: <equivalence> = reference' sample')) - ([#Primitive primitive-equivalence]) + ([#Primitive ..primitive-equivalence] + [#Structure (analysis.composite-equivalence =)] + [#Reference reference.equivalence] + [#Control (control-equivalence =)] + [#Extension (extension.equivalence =)]) _ false))) diff --git a/stdlib/source/lux/tool/compiler/reference/variable.lux b/stdlib/source/lux/tool/compiler/reference/variable.lux index 10c080c6e..e0c814e8d 100644 --- a/stdlib/source/lux/tool/compiler/reference/variable.lux +++ b/stdlib/source/lux/tool/compiler/reference/variable.lux @@ -42,9 +42,12 @@ (#Foreign register) (|> register .int (i.* -1) .nat))))) +(template: #export (self) + (#..Local 0)) + (def: #export self? (-> Variable Bit) - (|>> (case> (^ (#Local 0)) + (|>> (case> (^ (..self)) true _ diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index 7fc1c428d..29c34b430 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -21,6 +21,7 @@ ["#." io] ["#." parser ["#/." analysis] + ["#/." binary] ["#/." text] ["#/." cli]] ["#." pipe] @@ -59,6 +60,7 @@ ($_ _.and /parser.test /parser/analysis.test + /parser/binary.test /parser/text.test /parser/cli.test )) diff --git a/stdlib/source/test/lux/control/parser/binary.lux b/stdlib/source/test/lux/control/parser/binary.lux new file mode 100644 index 000000000..d646852f3 --- /dev/null +++ b/stdlib/source/test/lux/control/parser/binary.lux @@ -0,0 +1,359 @@ +(.module: + [lux (#- primitive) + ["_" test (#+ Test)] + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ do)]] + [control + ["." try] + ["." exception] + ["<>" parser]] + [data + ["." binary] + ["." sum] + ["." maybe] + ["." bit] + ["." name] + ["." text ("#@." equivalence) + ["." encoding]] + ["." format #_ + ["#" binary]] + [number + ["." i64] + ["n" nat] + ["." int] + ["." rev] + ["." frac]] + [collection + ["." list] + ["." row] + ["." set]]] + [macro + ["." code]] + ["." type] + [math + ["." random (#+ Random)]]] + {1 + ["." /]}) + +(template: (!expect <expectation> <computation>) + (case <computation> + <expectation> + true + + _ + false)) + +(def: segment-size 10) + +(def: random-name + (Random Name) + (random.and (random.unicode ..segment-size) + (random.unicode ..segment-size))) + +(structure: cursor-equivalence + (Equivalence Cursor) + + (def: (= [expected-module expected-line expected-column] + [sample-module sample-line sample-column]) + (and (text@= expected-module sample-module) + (n.= expected-line sample-line) + (n.= expected-column sample-column)))) + +(def: random-cursor + (Random Cursor) + ($_ random.and + (random.unicode ..segment-size) + random.nat + random.nat)) + +(def: random-code + (Random Code) + (random.rec + (function (_ recur) + (let [random-sequence (do {@ random.monad} + [size (:: @ map (n.% 2) random.nat)] + (random.list size recur))] + ($_ random.and + ..random-cursor + (: (Random (Code' (Ann Cursor))) + ($_ random.or + random.bit + random.nat + random.int + random.rev + random.frac + (random.unicode ..segment-size) + ..random-name + ..random-name + random-sequence + random-sequence + (do {@ random.monad} + [size (:: @ map (n.% 2) random.nat)] + (random.list size (random.and recur recur))) + ))))))) + +(def: random-type + (Random Type) + (let [(^open ".") random.monad] + ($_ random.either + (wrap .Nat) + (wrap .List) + (wrap .Code) + (wrap .Type)))) + +(def: size + Test + (<| (_.with-cover [/.Size]) + (`` ($_ _.and + (~~ (template [<size> <parser> <format>] + [(do {@ random.monad} + [expected (:: @ map (i64.and (i64.mask <size>)) + random.nat)] + (_.cover [<size> <parser>] + (|> (format.run <format> expected) + (/.run <parser>) + (!expect (^multi (#try.Success actual) + (n.= (.nat expected) + (.nat actual)))))))] + + [/.size/8 /.bits/8 format.bits/8] + [/.size/16 /.bits/16 format.bits/16] + [/.size/32 /.bits/32 format.bits/32] + [/.size/64 /.bits/64 format.bits/64] + )))))) + +(def: binary + Test + (`` ($_ _.and + (~~ (template [<parser> <format>] + [(do {@ random.monad} + [expected (:: @ map encoding.to-utf8 (random.ascii ..segment-size))] + (_.cover [<parser>] + (|> (format.run <format> expected) + (/.run <parser>) + (!expect (^multi (#try.Success actual) + (:: binary.equivalence = expected actual))))))] + + [/.binary/8 format.binary/8] + [/.binary/16 format.binary/16] + [/.binary/32 format.binary/32] + [/.binary/64 format.binary/64] + ))))) + +(def: utf8 + Test + (`` ($_ _.and + (~~ (template [<parser> <format>] + [(do {@ random.monad} + [expected (random.ascii ..segment-size)] + (_.cover [<parser>] + (|> (format.run <format> expected) + (/.run <parser>) + (!expect (^multi (#try.Success actual) + (:: text.equivalence = expected actual))))))] + + [/.utf8/8 format.utf8/8] + [/.utf8/16 format.utf8/16] + [/.utf8/32 format.utf8/32] + [/.utf8/64 format.utf8/64] + [/.text format.utf8/64] + ))))) + +(def: row + Test + (`` ($_ _.and + (~~ (template [<parser> <format>] + [(do {@ random.monad} + [expected (random.row ..segment-size random.nat)] + (_.cover [<parser>] + (|> expected + (format.run (<format> format.nat)) + (/.run (<parser> /.nat)) + (!expect (^multi (#try.Success actual) + (:: (row.equivalence n.equivalence) = expected actual))))))] + + [/.row/8 format.row/8] + [/.row/16 format.row/16] + [/.row/32 format.row/32] + [/.row/64 format.row/64] + ))))) + +(def: simple + Test + (`` ($_ _.and + (~~ (template [<parser> <format> <random> <equivalence>] + [(do {@ random.monad} + [expected <random>] + (_.cover [<parser>] + (|> (format.run <format> expected) + (/.run <parser>) + (!expect (^multi (#try.Success actual) + (:: <equivalence> = expected actual))))))] + + [/.bit format.bit random.bit bit.equivalence] + [/.nat format.nat random.nat n.equivalence] + [/.int format.int random.int int.equivalence] + [/.rev format.rev random.rev rev.equivalence] + [/.frac format.frac random.frac frac.equivalence] + )) + (do {@ random.monad} + [expected (:: @ map (|>> (i64.and (i64.mask /.size/8)) + (n.max 2)) + random.nat)] + (_.cover [/.not-a-bit] + (|> expected + (format.run format.bits/8) + (/.run /.bit) + (!expect (^multi (#try.Failure error) + (exception.match? /.not-a-bit error)))))) + ))) + +(def: complex + Test + (`` ($_ _.and + (~~ (template [<parser> <format> <random> <equivalence>] + [(do {@ random.monad} + [expected <random>] + (_.cover [<parser>] + (|> (format.run <format> expected) + (/.run <parser>) + (!expect (^multi (#try.Success actual) + (:: <equivalence> = expected actual))))))] + + [/.cursor format.cursor random-cursor cursor-equivalence] + [/.code format.code random-code code.equivalence] + [/.type format.type random-type type.equivalence] + )) + (~~ (template [<cover> <parser> <format> <random> <equivalence>] + [(do {@ random.monad} + [expected <random>] + (_.cover [<cover>] + (|> (format.run <format> expected) + (/.run <parser>) + (!expect (^multi (#try.Success actual) + (:: <equivalence> = expected actual))))))] + + [/.maybe (/.maybe /.nat) (format.maybe format.nat) (random.maybe random.nat) (maybe.equivalence n.equivalence)] + [/.list (/.list /.nat) (format.list format.nat) (random.list ..segment-size random.nat) (list.equivalence n.equivalence)] + [/.set (/.set n.hash /.nat) (format.set format.nat) (random.set n.hash ..segment-size random.nat) set.equivalence] + [/.name /.name format.name ..random-name name.equivalence] + )) + (do {@ random.monad} + [expected (:: @ map (list.repeat ..segment-size) random.nat)] + (_.cover [/.set-elements-are-not-unique] + (|> expected + (format.run (format.list format.nat)) + (/.run (/.set n.hash /.nat)) + (!expect (^multi (#try.Failure error) + (exception.match? /.set-elements-are-not-unique error)))))) + (do {@ random.monad} + [expected (random.or random.bit random.nat)] + (_.cover [/.or] + (|> expected + (format.run (format.or format.bit format.nat)) + (/.run (: (/.Parser (Either Bit Nat)) + (/.or /.bit /.nat))) + (!expect (^multi (#try.Success actual) + (:: (sum.equivalence bit.equivalence n.equivalence) = + expected + actual)))))) + (do {@ random.monad} + [tag (:: @ map (|>> (i64.and (i64.mask /.size/8)) + (n.max 2)) + random.nat) + value random.bit] + (_.cover [/.invalid-tag] + (|> [tag value] + (format.run (format.and format.bits/8 format.bit)) + (/.run (: (/.Parser (Either Bit Nat)) + (/.or /.bit /.nat))) + (!expect (^multi (#try.Failure error) + (exception.match? /.invalid-tag error)))))) + (do {@ random.monad} + [expected (random.list ..segment-size random.nat)] + (_.cover [/.rec] + (|> expected + (format.run (format.list format.nat)) + (/.run (: (/.Parser (List Nat)) + (/.rec + (function (_ recur) + (/.or /.any + (<>.and /.nat + recur)))))) + (!expect (^multi (#try.Success actual) + (:: (list.equivalence n.equivalence) = + expected + actual)))))) + ))) + +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [/.Parser]) + (`` ($_ _.and + (_.cover [/.run /.any] + (|> (binary.create 0) + (/.run /.any) + (!expect (#try.Success _)))) + (do {@ random.monad} + [data (:: @ map encoding.to-utf8 (random.ascii ..segment-size))] + (_.cover [/.binary-was-not-fully-read] + (|> data + (/.run /.any) + (!expect (^multi (#try.Failure error) + (exception.match? /.binary-was-not-fully-read error)))))) + (do {@ random.monad} + [expected (:: @ map encoding.to-utf8 (random.ascii ..segment-size))] + (_.cover [/.segment] + (|> expected + (/.run (/.segment ..segment-size)) + (!expect (^multi (#try.Success actual) + (:: binary.equivalence = expected actual)))))) + (do {@ random.monad} + [data (:: @ map encoding.to-utf8 (random.ascii ..segment-size))] + (_.cover [/.end?] + (|> data + (/.run (do <>.monad + [pre /.end? + _ (/.segment ..segment-size) + post /.end?] + (wrap (and (not pre) + post)))) + (!expect (#try.Success #1))))) + (do {@ random.monad} + [to-read (:: @ map (n.% (inc ..segment-size)) random.nat) + data (:: @ map encoding.to-utf8 (random.ascii ..segment-size))] + (_.cover [/.Offset /.offset] + (|> data + (/.run (do <>.monad + [start /.offset + _ (/.segment to-read) + offset /.offset + _ (/.segment (n.- to-read ..segment-size)) + nothing-left /.offset] + (wrap (and (n.= 0 start) + (n.= to-read offset) + (n.= ..segment-size nothing-left))))) + (!expect (#try.Success #1))))) + (do {@ random.monad} + [to-read (:: @ map (n.% (inc ..segment-size)) random.nat) + data (:: @ map encoding.to-utf8 (random.ascii ..segment-size))] + (_.cover [/.remaining] + (|> data + (/.run (do <>.monad + [_ (/.segment to-read) + remaining /.remaining + _ (/.segment (n.- to-read ..segment-size)) + nothing-left /.remaining] + (wrap (and (n.= ..segment-size + (n.+ to-read remaining)) + (n.= 0 nothing-left))))) + (!expect (#try.Success #1))))) + ..size + ..binary + ..utf8 + ..row + ..simple + ..complex + )))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux index da9937862..46291b311 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux @@ -5,7 +5,8 @@ ["#." primitive] ["#." structure] ["#." case] - ["#." function]]) + ["#." function] + ["#." loop]]) (def: #export test Test @@ -14,4 +15,5 @@ /structure.test /case.test /function.test + /loop.test )) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/loop.lux new file mode 100644 index 000000000..adb98ba3a --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/loop.lux @@ -0,0 +1,293 @@ +(.module: + [lux (#- primitive structure loop function) + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try] + ["." exception]] + [data + [number + ["n" nat]] + [collection + ["." list ("#@." functor)]]] + [math + ["." random (#+ Random) ("#@." monad)]]] + {1 + ["." / + [//// + ["." analysis (#+ Environment)] + ["/#" synthesis (#+ Member Path Synthesis)] + [/// + [arity (#+ Arity)] + ["." reference (#+ Constant) + ["." variable (#+ Register Variable)]]]]]}) + +(type: (Scenario a) + (-> Register Arity Register (Random [Register [a a]]))) + +(def: (primitive offset arity next) + (Scenario Synthesis) + (`` ($_ random.either + (~~ (template [<synthesis> <random>] + [(do {@ random.monad} + [example (:: @ map (|>> <synthesis>) <random>)] + (wrap [next + [example + example]]))] + + [//.bit random.bit] + [//.i64 (:: @ map .i64 random.nat)] + [//.f64 random.frac] + [//.text (random.unicode 1)] + )) + ))) + +(def: (constant offset arity next) + (Scenario Constant) + (do random.monad + [name (random.and (random.unicode 1) + (random.unicode 1))] + (wrap [next + [name + name]]))) + +(def: (variable offset arity next) + (Scenario Variable) + (let [local (do {@ random.monad} + [register (:: @ map (|>> (n.% arity) inc) random.nat)] + (wrap [next + [(#variable.Local (/.register-optimization offset register)) + (#variable.Local register)]]))] + (case offset + 0 local + _ ($_ random.either + local + (do {@ random.monad} + [foreign (:: @ map (n.% offset) random.nat)] + (wrap [next + [(#variable.Local foreign) + (#variable.Foreign foreign)]])))))) + +(def: (reference offset arity next) + (Scenario Synthesis) + (`` ($_ random.either + (~~ (template [<tag> <random>] + [(do {@ random.monad} + [[next [exampleE exampleA]] (<random> offset arity next)] + (wrap [next + [(<tag> exampleE) + (<tag> exampleA)]]))] + + [//.constant ..constant] + [//.variable ..variable] + ))))) + +(def: (structure offset arity next) + (Scenario Synthesis) + ($_ random.either + (do {@ random.monad} + [lefts random.nat + right? random.bit + [next [valueE valueA]] (..reference offset arity next)] + (wrap [next + [(//.variant + {#analysis.lefts lefts + #analysis.right? right? + #analysis.value valueE}) + (//.variant + {#analysis.lefts lefts + #analysis.right? right? + #analysis.value valueA})]])) + (do {@ random.monad} + [[next [leftE leftA]] (..reference offset arity next) + [next [rightE rightA]] (..reference offset arity next)] + (wrap [next + [(//.tuple (list leftE rightE)) + (//.tuple (list leftA rightA))]])) + )) + +(def: path + (Scenario Path) + (let [pattern (: (Scenario Path) + (.function (recur offset arity next) + (`` ($_ random.either + (random@wrap [next + [//.path/pop + //.path/pop]]) + (~~ (template [<path> <random>] + [(do {@ random.monad} + [example (:: @ map (|>> <path>) <random>)] + (wrap [next + [example + example]]))] + + [//.path/bit random.bit] + [//.path/i64 (:: @ map .i64 random.nat)] + [//.path/f64 random.frac] + [//.path/text (random.unicode 1)] + )) + (~~ (template [<path>] + [(do {@ random.monad} + [example (:: @ map (|>> <path>) + (random.or random.nat + random.nat))] + (wrap [next + [example + example]]))] + + [//.path/side] + [//.path/member] + )) + (random@wrap [(inc next) + [(//.path/bind (/.register-optimization offset next)) + (//.path/bind next)]]) + )))) + sequential (: (Scenario Path) + (.function (recur offset arity next) + (do random.monad + [[next [patternE patternA]] (pattern offset arity next) + [next [bodyE bodyA]] (..reference offset arity next)] + (wrap [next + [(//.path/seq patternE (//.path/then bodyE)) + (//.path/seq patternA (//.path/then bodyA))]]))))] + (.function (recur offset arity next) + (do random.monad + [[next [leftE leftA]] (sequential offset arity next) + [next [rightE rightA]] (sequential offset arity next)] + (wrap [next + [(//.path/alt leftE rightE) + (//.path/alt leftA rightA)]]))))) + +(def: (branch offset arity next) + (Scenario Synthesis) + (let [random-member (: (Random Member) + (random.or random.nat + random.nat))] + ($_ random.either + ($_ random.either + (do {@ random.monad} + [[next [inputE inputA]] (..reference offset arity next) + [next [bodyE bodyA]] (..reference offset arity next)] + (wrap [next + [(//.branch/let [inputE (/.register-optimization offset next) bodyE]) + (//.branch/let [inputA next bodyA])]])) + (do {@ random.monad} + [[next [testE testA]] (..reference offset arity next) + [next [thenE thenA]] (..reference offset arity next) + [next [elseE elseA]] (..reference offset arity next)] + (wrap [next + [(//.branch/if [testE thenE elseE]) + (//.branch/if [testA thenA elseA])]]))) + ($_ random.either + (do {@ random.monad} + [[next [recordE recordA]] (..reference offset arity next) + path-length (:: @ map (|>> (n.% 5) inc) random.nat) + path (random.list path-length random-member)] + (wrap [next + [(//.branch/get [path recordE]) + (//.branch/get [path recordA])]])) + (do {@ random.monad} + [[next [inputE inputA]] (..reference offset arity next) + [next [pathE pathA]] (..path offset arity next)] + (wrap [next + [(//.branch/case [inputE pathE]) + (//.branch/case [inputA pathA])]]))) + ))) + +(def: (loop offset arity next) + (Scenario Synthesis) + ($_ random.either + (do random.monad + [[next [firstE firstA]] (..reference offset arity next) + [next [secondE secondA]] (..reference offset arity next) + [next [iterationE iterationA]] (..reference offset arity next)] + (wrap [next + [(//.loop/scope + {#//.start (/.register-optimization offset next) + #//.inits (list firstE secondE) + #//.iteration iterationE}) + (//.loop/scope + {#//.start next + #//.inits (list firstA secondA) + #//.iteration iterationA})]])) + )) + +(def: (function offset arity next) + (Scenario Synthesis) + ($_ random.either + (do {@ random.monad} + [[next [firstE firstA]] (..variable offset arity next) + [next [secondE secondA]] (..variable offset arity next) + arity (:: @ map (n.max 1) random.nat) + [next [bodyE bodyA]] (..primitive 0 arity next)] + (wrap [next + [(//.function/abstraction + {#//.environment (list firstE secondE) + #//.arity arity + #//.body bodyE}) + (//.function/abstraction + {#//.environment (list firstA secondA) + #//.arity arity + #//.body bodyA})]])) + )) + +(def: (control offset arity next) + (Scenario Synthesis) + ($_ random.either + (..branch offset arity next) + (..loop offset arity next) + (..function offset arity next) + )) + +(def: (extension offset arity next) + (Scenario Synthesis) + (do random.monad + [name (random.unicode 10) + [next [firstE firstA]] (..reference offset arity next) + [next [secondE secondA]] (..reference offset arity next) + [next [thirdE thirdA]] (..reference offset arity next)] + (wrap [next + [(#//.Extension name (list firstE secondE thirdE)) + (#//.Extension name (list firstA secondA thirdA))]]))) + +(def: (scenario offset arity next) + (Scenario Synthesis) + ($_ random.either + (..primitive offset arity next) + (..structure offset arity next) + (..reference offset arity next) + (..control offset arity next) + (..extension offset arity next) + )) + +(def: #export test + Test + (<| (_.covering /._) + ($_ _.and + (do {@ random.monad} + [expected-offset (:: @ map (|>> (n.% 5) (n.+ 2)) random.nat) + arity (:: @ map (|>> (n.% 5) inc) random.nat) + expected-inits (|> random.nat + (:: @ map (|>> .i64 //.i64)) + (random.list arity)) + [_ [expected iteration]] (..scenario expected-offset arity 0)] + (_.cover [/.Transform /.optimization /.register-optimization] + (case (/.optimization expected-offset expected-inits + {#//.environment (|> expected-offset + list.indices + (list@map (|>> #variable.Local))) + #//.arity arity + #//.body iteration}) + (^ (#.Some (//.loop/scope [actual-offset actual-inits + actual]))) + (and (n.= expected-offset + actual-offset) + (:: (list.equivalence //.equivalence) = + expected-inits + actual-inits) + (:: //.equivalence = expected actual)) + + _ + false))) + ))) |