aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/parser/synthesis.lux19
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux27
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux410
-rw-r--r--stdlib/source/test/lux/control.lux2
-rw-r--r--stdlib/source/test/lux/control/parser/synthesis.lux161
-rw-r--r--stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis.lux4
-rw-r--r--stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/variable.lux335
7 files changed, 936 insertions, 22 deletions
diff --git a/stdlib/source/lux/control/parser/synthesis.lux b/stdlib/source/lux/control/parser/synthesis.lux
index 5e3b1dadb..b4ad2184b 100644
--- a/stdlib/source/lux/control/parser/synthesis.lux
+++ b/stdlib/source/lux/control/parser/synthesis.lux
@@ -26,16 +26,10 @@
["/" synthesis (#+ Synthesis Abstraction)]]]]]]
["." //])
-(def: (remaining-inputs asts)
- (-> (List Synthesis) Text)
- (format text.new-line "Remaining input: "
- (|> asts
- (list@map /.%synthesis)
- (list.interpose " ")
- (text.join-with ""))))
-
## TODO: Use "type:" ASAP.
-(def: Input Type (type (List Synthesis)))
+(def: Input
+ Type
+ (type (List Synthesis)))
(exception: #export (cannot-parse {input ..Input})
(exception.report
@@ -45,6 +39,10 @@
(exception.report
["Input" (exception.enumerate /.%synthesis input)]))
+(exception: #export (expected-empty-input {input ..Input})
+ (exception.report
+ ["Input" (exception.enumerate /.%synthesis input)]))
+
(exception: #export (wrong-arity {expected Arity} {actual Arity})
(exception.report
["Expected" (%.nat expected)]
@@ -83,8 +81,7 @@
(.function (_ tokens)
(case tokens
#.Nil (#try.Success [tokens []])
- _ (#try.Failure (format "Expected list of tokens to be empty!"
- (remaining-inputs tokens))))))
+ _ (exception.throw ..expected-empty-input [tokens]))))
(def: #export end?
{#.doc "Checks whether there are no more inputs."}
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
index 33e94f89a..54f299c31 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
@@ -13,6 +13,7 @@
["." / #_
["#." function]
["#." case]
+ ["#." variable]
["/#" // #_
["#." extension]
["/#" // #_
@@ -42,9 +43,9 @@
[#///analysis.Int #/.I64]
[#///analysis.Rev #/.I64])))
-(def: #export (phase archive)
+(def: (optimization archive)
Phase
- (function (phase' analysis)
+ (function (optimization' analysis)
(case analysis
(#///analysis.Primitive analysis')
(phase@wrap (#/.Primitive (..primitive analysis')))
@@ -54,12 +55,12 @@
(case structure
(#///analysis.Variant variant)
(do phase.monad
- [valueS (phase' (get@ #///analysis.value variant))]
+ [valueS (optimization' (get@ #///analysis.value variant))]
(wrap (/.variant (set@ #///analysis.value valueS variant))))
(#///analysis.Tuple tuple)
(|> tuple
- (monad.map phase.monad phase')
+ (monad.map phase.monad optimization')
(phase@map (|>> /.tuple)))))
(#///analysis.Reference reference)
@@ -67,29 +68,35 @@
(#///analysis.Case inputA branchesAB+)
(/.with-currying? false
- (/case.synthesize phase branchesAB+ archive inputA))
+ (/case.synthesize optimization branchesAB+ archive inputA))
(^ (///analysis.no-op value))
- (phase' value)
+ (optimization' value)
(#///analysis.Apply _)
(/.with-currying? false
- (/function.apply phase archive analysis))
+ (/function.apply optimization archive analysis))
(#///analysis.Function environmentA bodyA)
- (/function.abstraction phase environmentA archive bodyA)
+ (/function.abstraction optimization environmentA archive bodyA)
(#///analysis.Extension name args)
(/.with-currying? false
(function (_ state)
- (|> (//extension.apply archive phase [name args])
+ (|> (//extension.apply archive optimization [name args])
(phase.run' state)
(case> (#try.Success output)
(#try.Success output)
(#try.Failure _)
(|> args
- (monad.map phase.monad phase')
+ (monad.map phase.monad optimization')
(phase@map (|>> [name] #/.Extension))
(phase.run' state))))))
)))
+
+(def: #export (phase archive analysis)
+ Phase
+ (do phase.monad
+ [synthesis (..optimization archive analysis)]
+ (phase.lift (/variable.optimization synthesis))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux
new file mode 100644
index 000000000..dd0d49608
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux
@@ -0,0 +1,410 @@
+(.module:
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." product]
+ ["." maybe]
+ [number
+ ["n" nat]]
+ ["." text
+ ["%" format]]
+ [collection
+ ["." dictionary (#+ Dictionary)]
+ ["." list ("#@." functor fold)]
+ ["." set]]]]
+ [////
+ ["/" synthesis (#+ Path Synthesis)]
+ ["." analysis]
+ [///
+ [arity (#+ Arity)]
+ ["." reference
+ ["." variable (#+ Register Variable)]]]])
+
+(def: (prune redundant register)
+ (-> Register Register Register)
+ (if (n.> redundant register)
+ (dec register)
+ register))
+
+(type: (Remover a)
+ (-> Register (-> a a)))
+
+(def: (remove-local-from-path remove-local redundant)
+ (-> (Remover Synthesis) (Remover Path))
+ (function (recur path)
+ (case path
+ (#/.Seq (#/.Bind register)
+ post)
+ (if (n.= redundant register)
+ (recur post)
+ (#/.Seq (#/.Bind (if (n.> redundant register)
+ (dec register)
+ register))
+ (recur post)))
+
+ (^or (#/.Seq (#/.Access (#/.Member member))
+ (#/.Seq (#/.Bind register)
+ post))
+ ## This alternative form should never occur in practice.
+ ## Yet, it is "technically" possible to construct it.
+ (#/.Seq (#/.Seq (#/.Access (#/.Member member))
+ (#/.Bind register))
+ post))
+ (if (n.= redundant register)
+ (recur post)
+ (#/.Seq (#/.Access (#/.Member member))
+ (#/.Seq (#/.Bind (if (n.> redundant register)
+ (dec register)
+ register))
+ (recur post))))
+
+ (^template [<tag>]
+ (<tag> left right)
+ (<tag> (recur left) (recur right)))
+ ([#/.Seq]
+ [#/.Alt])
+
+ (^or #/.Pop
+ (#/.Test _)
+ (#/.Access _))
+ path
+
+ (#/.Bind register)
+ (undefined)
+
+ (#/.Then then)
+ (#/.Then (remove-local redundant then))
+ )))
+
+(def: (remove-local-from-variable redundant variable)
+ (Remover Variable)
+ (case variable
+ (#variable.Local register)
+ (#variable.Local (..prune redundant register))
+
+ (#variable.Foreign register)
+ variable))
+
+(def: (remove-local redundant)
+ (Remover Synthesis)
+ (function (recur synthesis)
+ (case synthesis
+ (#/.Primitive _)
+ synthesis
+
+ (#/.Structure structure)
+ (#/.Structure (case structure
+ (#analysis.Variant [lefts right value])
+ (#analysis.Variant [lefts right (recur value)])
+
+ (#analysis.Tuple tuple)
+ (#analysis.Tuple (list@map recur tuple))))
+
+ (#/.Reference reference)
+ (case reference
+ (#reference.Variable variable)
+ (/.variable (..remove-local-from-variable redundant variable))
+
+ (#reference.Constant constant)
+ synthesis)
+
+ (#/.Control control)
+ (#/.Control (case control
+ (#/.Branch branch)
+ (#/.Branch (case branch
+ (#/.Let input register output)
+ (#/.Let (recur input)
+ (..prune redundant register)
+ (recur output))
+
+ (#/.If test then else)
+ (#/.If (recur test) (recur then) (recur else))
+
+ (#/.Get path record)
+ (#/.Get path (recur record))
+
+ (#/.Case input path)
+ (#/.Case (recur input) (remove-local-from-path remove-local redundant path))))
+
+ (#/.Loop loop)
+ (#/.Loop (case loop
+ (#/.Scope [start inits iteration])
+ (#/.Scope [(..prune redundant start)
+ (list@map recur inits)
+ (recur iteration)])
+
+ (#/.Recur resets)
+ (#/.Recur (list@map recur resets))))
+
+ (#/.Function function)
+ (#/.Function (case function
+ (#/.Abstraction [environment arity body])
+ (#/.Abstraction [(list@map (..remove-local-from-variable redundant) environment)
+ arity
+ body])
+
+ (#/.Apply abstraction inputs)
+ (#/.Apply (recur abstraction) (list@map recur inputs))))))
+
+ (#/.Extension name inputs)
+ (#/.Extension name (list@map recur inputs)))))
+
+(type: Redundancy
+ (Dictionary Register Bit))
+
+(def: initial
+ Redundancy
+ (dictionary.new n.hash))
+
+(def: redundant! true)
+(def: necessary! false)
+
+(def: (extended offset amount redundancy)
+ (-> Register Nat Redundancy [(List Register) Redundancy])
+ (let [extension (|> amount list.indices (list@map (n.+ offset)))]
+ [extension
+ (list@fold (function (_ register redundancy)
+ (dictionary.put register ..necessary! redundancy))
+ redundancy
+ extension)]))
+
+(def: (default arity)
+ (-> Arity Redundancy)
+ (product.right (..extended 0 (inc arity) ..initial)))
+
+(type: (Optimization a)
+ (-> [Redundancy a] (Try [Redundancy a])))
+
+(def: (list-optimization optimization)
+ (-> (Optimization Synthesis) (Optimization (List Synthesis)))
+ (function (recur [redundancy values])
+ (case values
+ #.Nil
+ (#try.Success [redundancy
+ values])
+
+ (#.Cons head tail)
+ (do try.monad
+ [[redundancy head] (optimization [redundancy head])
+ [redundancy tail] (recur [redundancy tail])]
+ (wrap [redundancy
+ (#.Cons head tail)])))))
+
+(template [<name>]
+ [(exception: #export (<name> {register Register})
+ (exception.report
+ ["Register" (%.nat register)]))]
+
+ [redundant-declaration]
+ [unknown-register]
+ )
+
+(def: (declare register redundancy)
+ (-> Register Redundancy (Try Redundancy))
+ (case (dictionary.get register redundancy)
+ #.None
+ (#try.Success (dictionary.put register ..redundant! redundancy))
+
+ (#.Some _)
+ (exception.throw ..redundant-declaration [register])))
+
+(def: (observe register redundancy)
+ (-> Register Redundancy (Try Redundancy))
+ (case (dictionary.get register redundancy)
+ #.None
+ (exception.throw ..unknown-register [register])
+
+ (#.Some _)
+ (#try.Success (dictionary.put register ..necessary! redundancy))))
+
+(def: (format redundancy)
+ (%.Format Redundancy)
+ (|> redundancy
+ dictionary.entries
+ (list@map (function (_ [register redundant?])
+ (%.format (%.nat register) ": " (%.bit redundant?))))
+ (text.join-with ", ")))
+
+(def: (path-optimization optimization)
+ (-> (Optimization Synthesis) (Optimization Path))
+ (function (recur [redundancy path])
+ (case path
+ (^or #/.Pop
+ (#/.Test _)
+ (#/.Access _))
+ (#try.Success [redundancy
+ path])
+
+ (#/.Bind register)
+ (do try.monad
+ [redundancy (..declare register redundancy)]
+ (wrap [redundancy
+ path]))
+
+ (#/.Alt left right)
+ (do try.monad
+ [[redundancy left] (recur [redundancy left])
+ [redundancy right] (recur [redundancy right])]
+ (wrap [redundancy (#/.Alt left right)]))
+
+ (#/.Seq pre post)
+ (do try.monad
+ [#let [baseline (|> redundancy
+ dictionary.keys
+ (set.from-list n.hash))]
+ [redundancy pre] (recur [redundancy pre])
+ #let [bindings (|> redundancy
+ dictionary.keys
+ (set.from-list n.hash)
+ (set.difference baseline))]
+ [redundancy post] (recur [redundancy post])
+ #let [redundants (|> redundancy
+ dictionary.entries
+ (list.filter (function (_ [register redundant?])
+ (and (set.member? bindings register)
+ redundant?)))
+ (list@map product.left))]]
+ (wrap [(list@fold dictionary.remove redundancy (set.to-list bindings))
+ (|> redundants
+ (list.sort n.>)
+ (list@fold (..remove-local-from-path ..remove-local) (#/.Seq pre post)))]))
+
+ (#/.Then then)
+ (do try.monad
+ [[redundancy then] (optimization [redundancy then])]
+ (wrap [redundancy (#/.Then then)]))
+ )))
+
+(def: (variable-optimization variable redundancy)
+ (-> Variable Redundancy (Try Redundancy))
+ (case variable
+ (#variable.Local register)
+ (..observe register redundancy)
+
+ (#variable.Foreign register)
+ (#try.Success redundancy)))
+
+(def: (optimization' [redundancy synthesis])
+ (Optimization Synthesis)
+ (with-expansions [<no-op> (as-is (#try.Success [redundancy
+ synthesis]))]
+ (case synthesis
+ (#/.Primitive _)
+ <no-op>
+
+ (#/.Structure structure)
+ (case structure
+ (#analysis.Variant [lefts right value])
+ (do try.monad
+ [[redundancy value] (optimization' [redundancy value])]
+ (wrap [redundancy
+ (#/.Structure (#analysis.Variant [lefts right value]))]))
+
+ (#analysis.Tuple tuple)
+ (do try.monad
+ [[redundancy tuple] (..list-optimization optimization' [redundancy tuple])]
+ (wrap [redundancy
+ (#/.Structure (#analysis.Tuple tuple))])))
+
+ (#/.Reference reference)
+ (case reference
+ (#reference.Variable variable)
+ (case variable
+ (#variable.Local register)
+ (do try.monad
+ [redundancy (..observe register redundancy)]
+ <no-op>)
+
+ (#variable.Foreign register)
+ <no-op>)
+
+ (#reference.Constant constant)
+ <no-op>)
+
+ (#/.Control control)
+ (case control
+ (#/.Branch branch)
+ (case branch
+ (#/.Let input register output)
+ (do try.monad
+ [[redundancy input] (optimization' [redundancy input])
+ redundancy (..declare register redundancy)
+ [redundancy output] (optimization' [redundancy output])
+ #let [redundant? (|> redundancy
+ (dictionary.get register)
+ (maybe.default ..necessary!))]]
+ (wrap [(dictionary.remove register redundancy)
+ (#/.Control (if redundant?
+ (#/.Branch (#/.Case input
+ (#/.Seq #/.Pop
+ (#/.Then (..remove-local register output)))))
+ (#/.Branch (#/.Let input register output))))]))
+
+ (#/.If test then else)
+ (do try.monad
+ [[redundancy test] (optimization' [redundancy test])
+ [redundancy then] (optimization' [redundancy then])
+ [redundancy else] (optimization' [redundancy else])]
+ (wrap [redundancy
+ (#/.Control (#/.Branch (#/.If test then else)))]))
+
+ (#/.Get path record)
+ (do try.monad
+ [[redundancy record] (optimization' [redundancy record])]
+ (wrap [redundancy
+ (#/.Control (#/.Branch (#/.Get path record)))]))
+
+ (#/.Case input path)
+ (do try.monad
+ [[redundancy input] (optimization' [redundancy input])
+ [redundancy path] (..path-optimization optimization' [redundancy path])]
+ (wrap [redundancy
+ (#/.Control (#/.Branch (#/.Case input path)))])))
+
+ (#/.Loop loop)
+ (case loop
+ (#/.Scope [start inits iteration])
+ (do try.monad
+ [[redundancy inits] (..list-optimization optimization' [redundancy inits])
+ #let [[extension redundancy] (..extended start (list.size inits) redundancy)]
+ [redundancy iteration] (optimization' [redundancy iteration])]
+ (wrap [(list@fold dictionary.remove redundancy extension)
+ (#/.Control (#/.Loop (#/.Scope [start inits iteration])))]))
+
+ (#/.Recur resets)
+ (do try.monad
+ [[redundancy resets] (..list-optimization optimization' [redundancy resets])]
+ (wrap [redundancy
+ (#/.Control (#/.Loop (#/.Recur resets)))])))
+
+ (#/.Function function)
+ (case function
+ (#/.Abstraction [environment arity body])
+ (do {@ try.monad}
+ [redundancy (monad.fold @ ..variable-optimization redundancy environment)
+ [_ body] (optimization' [(..default arity) body])]
+ (wrap [redundancy
+ (#/.Control (#/.Function (#/.Abstraction [environment arity body])))]))
+
+ (#/.Apply abstraction inputs)
+ (do try.monad
+ [[redundancy abstraction] (optimization' [redundancy abstraction])
+ [redundancy inputs] (..list-optimization optimization' [redundancy inputs])]
+ (wrap [redundancy
+ (#/.Control (#/.Function (#/.Apply abstraction inputs)))]))))
+
+ (#/.Extension name inputs)
+ (do try.monad
+ [[redundancy inputs] (..list-optimization optimization' [redundancy inputs])]
+ (wrap [redundancy
+ (#/.Extension name inputs)])))))
+
+(def: #export optimization
+ (-> Synthesis (Try Synthesis))
+ (|>> [..initial]
+ optimization'
+ (:: try.monad map product.right)))
diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux
index 80a94be6f..c0c673009 100644
--- a/stdlib/source/test/lux/control.lux
+++ b/stdlib/source/test/lux/control.lux
@@ -25,6 +25,7 @@
["#/." cli]
["#/." code]
["#/." json]
+ ["#/." synthesis]
["#/." text]]
["#." pipe]
["#." reader]
@@ -66,6 +67,7 @@
/parser/cli.test
/parser/code.test
/parser/json.test
+ /parser/synthesis.test
/parser/text.test
))
diff --git a/stdlib/source/test/lux/control/parser/synthesis.lux b/stdlib/source/test/lux/control/parser/synthesis.lux
new file mode 100644
index 000000000..5dbf6a383
--- /dev/null
+++ b/stdlib/source/test/lux/control/parser/synthesis.lux
@@ -0,0 +1,161 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]]
+ [math
+ ["." random (#+ Random)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ ["." exception]
+ ["<>" parser]]
+ [data
+ ["." bit]
+ ["." name]
+ ["." text]
+ [number
+ ["." i64]
+ ["n" nat]
+ ["." frac]]
+ [collection
+ ["." list ("#@." functor)]]]
+ [tool
+ [compiler
+ [reference (#+)
+ ["." variable (#+ Variable)]]
+ [language
+ [lux
+ [analysis (#+ Environment)]
+ ["." synthesis]]]]]]
+ {1
+ ["." /]})
+
+(template: (!expect <pattern> <value>)
+ (case <value>
+ <pattern>
+ true
+
+ _
+ false))
+
+(def: random-constant
+ (Random Name)
+ (random.and (random.unicode 1)
+ (random.unicode 1)))
+
+(def: random-variable
+ (Random Variable)
+ (random.or random.nat
+ random.nat))
+
+(def: random-environment
+ (Random Environment)
+ (do {@ random.monad}
+ [size (:: @ map (n.% 5) random.nat)]
+ (random.list size ..random-variable)))
+
+(def: #export test
+ Test
+ (<| (_.covering /._)
+ (_.with-cover [/.Parser])
+ ($_ _.and
+ (do {@ random.monad}
+ [expected (:: @ map (|>> synthesis.i64) random.nat)]
+ (_.cover [/.run /.any]
+ (|> (/.run /.any (list expected))
+ (!expect (^multi (#try.Success actual)
+ (:: synthesis.equivalence = expected actual))))))
+ (_.cover [/.empty-input]
+ (|> (/.run /.any (list))
+ (!expect (^multi (#try.Failure error)
+ (exception.match? /.empty-input error)))))
+ (do {@ random.monad}
+ [expected (:: @ map (|>> synthesis.i64) random.nat)]
+ (_.cover [/.unconsumed-input]
+ (|> (/.run /.any (list expected expected))
+ (!expect (^multi (#try.Failure error)
+ (exception.match? /.unconsumed-input error))))))
+ (do {@ random.monad}
+ [dummy (:: @ map (|>> synthesis.i64) random.nat)]
+ (_.cover [/.end! /.expected-empty-input]
+ (and (|> (/.run /.end! (list))
+ (!expect (#try.Success _)))
+ (|> (/.run /.end! (list dummy))
+ (!expect (^multi (#try.Failure error)
+ (exception.match? /.expected-empty-input error)))))))
+ (do {@ random.monad}
+ [dummy (:: @ map (|>> synthesis.i64) random.nat)]
+ (_.cover [/.end?]
+ (and (|> (/.run /.end? (list))
+ (!expect (#try.Success #1)))
+ (|> (/.run (<>.before /.any /.end?) (list dummy))
+ (!expect (#try.Success #0))))))
+ (_.with-cover [/.cannot-parse]
+ (`` ($_ _.and
+ (~~ (template [<query> <check> <random> <synthesis> <equivalence>]
+ [(do {@ random.monad}
+ [expected <random>
+ dummy (|> <random> (random.filter (|>> (:: <equivalence> = expected) not)))]
+ ($_ _.and
+ (_.cover [<query>]
+ (|> (/.run <query> (list (<synthesis> expected)))
+ (!expect (^multi (#try.Success actual)
+ (:: <equivalence> = expected actual)))))
+ (_.cover [<check>]
+ (and (|> (/.run (<check> expected) (list (<synthesis> expected)))
+ (!expect (#try.Success _)))
+ (|> (/.run (<check> expected) (list (<synthesis> dummy)))
+ (!expect (^multi (#try.Failure error)
+ (exception.match? /.cannot-parse error))))))))]
+
+ [/.bit /.bit! random.bit synthesis.bit bit.equivalence]
+ [/.i64 /.i64! (:: @ map .i64 random.nat) synthesis.i64 i64.equivalence]
+ [/.f64 /.f64! random.frac synthesis.f64 frac.equivalence]
+ [/.text /.text! (random.unicode 1) synthesis.text text.equivalence]
+ [/.local /.local! random.nat synthesis.variable/local n.equivalence]
+ [/.foreign /.foreign! random.nat synthesis.variable/foreign n.equivalence]
+ [/.constant /.constant! ..random-constant synthesis.constant name.equivalence]
+ ))
+ (do {@ random.monad}
+ [expected-bit random.bit
+ expected-i64 (:: @ map .i64 random.nat)
+ expected-f64 random.frac
+ expected-text (random.unicode 1)]
+ (_.cover [/.tuple]
+ (and (|> (/.run (/.tuple ($_ <>.and /.bit /.i64 /.f64 /.text))
+ (list (synthesis.tuple (list (synthesis.bit expected-bit)
+ (synthesis.i64 expected-i64)
+ (synthesis.f64 expected-f64)
+ (synthesis.text expected-text)))))
+ (!expect (^multi (#try.Success [actual-bit actual-i64 actual-f64 actual-text])
+ (and (:: bit.equivalence = expected-bit actual-bit)
+ (:: i64.equivalence = expected-i64 actual-i64)
+ (:: frac.equivalence = expected-f64 actual-f64)
+ (:: text.equivalence = expected-text actual-text)))))
+ (|> (/.run (/.tuple ($_ <>.and /.bit /.i64 /.f64 /.text))
+ (list (synthesis.text expected-text)))
+ (!expect (^multi (#try.Failure error)
+ (exception.match? /.cannot-parse error)))))))
+ (do {@ random.monad}
+ [arity random.nat
+ expected-environment ..random-environment
+ expected-body (random.unicode 1)]
+ (_.cover [/.function /.wrong-arity]
+ (and (|> (/.run (/.function arity /.text)
+ (list (synthesis.function/abstraction [expected-environment arity (synthesis.text expected-body)])))
+ (!expect (^multi (#try.Success [actual-environment actual-body])
+ (and (:: (list.equivalence variable.equivalence) =
+ expected-environment
+ actual-environment)
+ (:: text.equivalence = expected-body actual-body)))))
+ (|> (/.run (/.function arity /.text)
+ (list (synthesis.text expected-body)))
+ (!expect (^multi (#try.Failure error)
+ (exception.match? /.cannot-parse error))))
+ (|> (/.run (/.function (inc arity) /.text)
+ (list (synthesis.function/abstraction [expected-environment arity (synthesis.text expected-body)])))
+ (!expect (^multi (#try.Failure error)
+ (exception.match? /.wrong-arity error)))))))
+ )))
+ )))
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 46291b311..4a7a7c507 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
@@ -6,7 +6,8 @@
["#." structure]
["#." case]
["#." function]
- ["#." loop]])
+ ["#." loop]
+ ["#." variable]])
(def: #export test
Test
@@ -16,4 +17,5 @@
/case.test
/function.test
/loop.test
+ /variable.test
))
diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/variable.lux
new file mode 100644
index 000000000..b90829862
--- /dev/null
+++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/variable.lux
@@ -0,0 +1,335 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]]
+ [math
+ ["." random (#+ Random)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]]
+ [data
+ ["." product]
+ ["." text
+ ["%" format (#+ format)]]
+ [number
+ ["n" nat]]
+ [collection
+ ["." list ("#@." functor fold)]
+ ["." dictionary (#+ Dictionary)]]]]
+ {1
+ ["." /
+ [////
+ ["." analysis]
+ ["." synthesis (#+ Side Member Path Synthesis)]
+ [///
+ [reference (#+)
+ ["." variable]]]]]})
+
+(template: (!expect <pattern> <value>)
+ (case <value>
+ <pattern>
+ true
+
+ _
+ false))
+
+(type: Context
+ {#redundants Nat
+ #necessary (Dictionary Nat Nat)})
+
+(type: (Scenario a)
+ (-> Context (Random [a a])))
+
+(template [<name> <synthesis> <random>]
+ [(def: (<name> context)
+ (Scenario Synthesis)
+ (do {@ random.monad}
+ [value <random>]
+ (wrap [(<synthesis> value)
+ (<synthesis> value)])))]
+
+ [bit-scenario synthesis.bit random.bit]
+ [i64-scenario synthesis.i64 (:: @ map .i64 random.nat)]
+ [f64-scenario synthesis.f64 random.frac]
+ [text-scenario synthesis.text (random.unicode 1)]
+ )
+
+(def: (primitive-scenario context)
+ (Scenario Synthesis)
+ (random.either (random.either (..bit-scenario context)
+ (..i64-scenario context))
+ (random.either (..f64-scenario context)
+ (..text-scenario context))))
+
+(def: (with-redundancy scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ (do {@ random.monad}
+ [redundant? random.bit]
+ (if redundant?
+ (do @
+ [let? random.bit
+ [expected-input actual-input] (..primitive-scenario context)
+ #let [fake-register (n.+ (get@ #redundants context)
+ (dictionary.size (get@ #necessary context)))]
+ [expected-output actual-output] (scenario (update@ #redundants inc context))]
+ (wrap [(synthesis.branch/case [expected-input
+ (#synthesis.Seq #synthesis.Pop
+ (#synthesis.Then expected-output))])
+ (if let?
+ (synthesis.branch/let [actual-input fake-register actual-output])
+ (synthesis.branch/case [actual-input
+ (#synthesis.Seq (#synthesis.Bind fake-register)
+ (#synthesis.Seq #synthesis.Pop
+ (#synthesis.Then actual-output)))]))]))
+ (scenario context))))
+
+(def: (variant-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ (do {@ random.monad}
+ [lefts random.nat
+ right? random.bit
+ [expected input] (scenario context)]
+ (wrap [(synthesis.variant [lefts right? expected])
+ (synthesis.variant [lefts right? input])])))
+
+(def: (tuple-scenario context)
+ (Scenario Synthesis)
+ (let [registers (dictionary.entries (get@ #necessary context))]
+ (:: random.monad wrap
+ [(synthesis.tuple (list@map (|>> product.left synthesis.variable/local) registers))
+ (synthesis.tuple (list@map (|>> product.right synthesis.variable/local) registers))])))
+
+(def: (structure-scenario context)
+ (Scenario Synthesis)
+ (random.either (..variant-scenario (..with-redundancy ..tuple-scenario) context)
+ (..tuple-scenario context)))
+
+(def: (let-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ (do random.monad
+ [_ (wrap [])
+ [expected-input actual-input] (scenario context)
+ #let [real-register (dictionary.size (get@ #necessary context))
+ fake-register (n.+ (get@ #redundants context)
+ (dictionary.size (get@ #necessary context)))]
+ [expected-output actual-output] (scenario (update@ #necessary (dictionary.put real-register fake-register) context))]
+ (wrap [(synthesis.branch/let [expected-input real-register expected-output])
+ (synthesis.branch/let [actual-input fake-register actual-output])])))
+
+(def: (if-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ (do random.monad
+ [_ (wrap [])
+ [expected-test actual-test] (scenario context)
+ [expected-then actual-then] (scenario context)
+ [expected-else actual-else] (scenario context)]
+ (wrap [(synthesis.branch/if [expected-test
+ expected-then
+ expected-else])
+ (synthesis.branch/if [actual-test
+ actual-then
+ actual-else])])))
+
+(def: random-member
+ (Random Member)
+ (do random.monad
+ [lefts random.nat
+ right? random.bit]
+ (wrap (if right?
+ (#.Right lefts)
+ (#.Left lefts)))))
+
+(def: (get-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ (do {@ random.monad}
+ [length (:: @ map (|>> (n.% 5) inc) random.nat)
+ path (random.list length ..random-member)
+ [expected-record actual-record] (scenario context)]
+ (wrap [(synthesis.branch/get [path expected-record])
+ (synthesis.branch/get [path actual-record])])))
+
+(def: random-side
+ (Random Side)
+ ..random-member)
+
+(def: (path-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Path))
+ (`` ($_ random.either
+ ($_ random.either
+ (do {@ random.monad}
+ [_ (wrap [])
+ [expected-then actual-then] (scenario context)]
+ (wrap [(#synthesis.Seq #synthesis.Pop
+ (#synthesis.Then expected-then))
+ (#synthesis.Seq #synthesis.Pop
+ (#synthesis.Then actual-then))]))
+ (do {@ random.monad}
+ [_ (wrap [])
+ #let [real-register (dictionary.size (get@ #necessary context))
+ fake-register (n.+ (get@ #redundants context)
+ (dictionary.size (get@ #necessary context)))]
+ [expected-then actual-then] (scenario (update@ #necessary (dictionary.put real-register fake-register) context))]
+ (wrap [(#synthesis.Seq (#synthesis.Bind real-register)
+ (#synthesis.Seq #synthesis.Pop
+ (#synthesis.Then expected-then)))
+ (#synthesis.Seq (#synthesis.Bind fake-register)
+ (#synthesis.Seq #synthesis.Pop
+ (#synthesis.Then actual-then)))])))
+ ($_ random.either
+ (~~ (template [<tag> <random>]
+ [(do {@ random.monad}
+ [test <random>
+ [expected-then actual-then] (scenario context)]
+ (wrap [(#synthesis.Seq (#synthesis.Test (<tag> test))
+ (#synthesis.Then expected-then))
+ (#synthesis.Seq (#synthesis.Test (<tag> test))
+ (#synthesis.Then actual-then))]))]
+
+ [#synthesis.Bit random.bit]
+ [#synthesis.I64 (:: @ map .i64 random.nat)]
+ [#synthesis.F64 random.frac]
+ [#synthesis.Text (random.unicode 1)]
+ )))
+ ($_ random.either
+ (do {@ random.monad}
+ [side ..random-side
+ [expected-next actual-next] (path-scenario scenario context)]
+ (wrap [(#synthesis.Seq (#synthesis.Access (#synthesis.Side side))
+ expected-next)
+ (#synthesis.Seq (#synthesis.Access (#synthesis.Side side))
+ actual-next)]))
+ (do {@ random.monad}
+ [member ..random-member
+ [expected-next actual-next] (path-scenario scenario context)]
+ (wrap [(#synthesis.Seq (#synthesis.Access (#synthesis.Member member))
+ expected-next)
+ (#synthesis.Seq (#synthesis.Access (#synthesis.Member member))
+ actual-next)])))
+ (do {@ random.monad}
+ [_ (wrap [])
+ [expected-left actual-left] (path-scenario scenario context)
+ [expected-right actual-right] (path-scenario scenario context)]
+ (wrap [(#synthesis.Alt expected-left expected-right)
+ (#synthesis.Alt actual-left actual-right)]))
+ )))
+
+(def: (case-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ (do {@ random.monad}
+ [_ (wrap [])
+ [expected-input actual-input] (scenario context)
+ [expected-path actual-path] (..path-scenario scenario context)]
+ (wrap [(synthesis.branch/case [expected-input expected-path])
+ (synthesis.branch/case [actual-input actual-path])])))
+
+(def: (branch-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ ($_ random.either
+ (..let-scenario scenario context)
+ (..if-scenario scenario context)
+ (..get-scenario scenario context)
+ (..case-scenario scenario context)
+ ))
+
+(def: scope-arity 5)
+
+(def: (scope-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ (do {@ random.monad}
+ [_ (wrap [])
+ #let [real-start (dictionary.size (get@ #necessary context))
+ fake-start (n.+ (get@ #redundants context)
+ real-start)]
+ inits (random.list ..scope-arity (scenario context))
+ [expected-iteration actual-iteration] (scenario (update@ #necessary
+ (function (_ necessary)
+ (list@fold (function (_ [idx _] context)
+ (dictionary.put (n.+ real-start idx)
+ (n.+ fake-start idx)
+ context))
+ necessary
+ (list.enumerate inits)))
+ context))]
+ (wrap [(synthesis.loop/scope [real-start (list@map product.left inits) expected-iteration])
+ (synthesis.loop/scope [fake-start (list@map product.right inits) actual-iteration])])))
+
+(def: (recur-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ (do {@ random.monad}
+ [_ (wrap [])
+ resets (random.list ..scope-arity (scenario context))]
+ (wrap [(synthesis.loop/recur (list@map product.left resets))
+ (synthesis.loop/recur (list@map product.right resets))])))
+
+(def: (loop-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ ($_ random.either
+ (..scope-scenario scenario context)
+ (..recur-scenario scenario context)
+ ))
+
+(def: (abstraction-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ (do {@ random.monad}
+ [_ (wrap [])
+ #let [registers (dictionary.entries (get@ #necessary context))
+ expected-environment (list@map (|>> product.left #variable.Local) registers)
+ actual-environment (list@map (|>> product.right #variable.Local) registers)]
+ [expected-body actual-body] (..primitive-scenario context)]
+ (wrap [(synthesis.function/abstraction [expected-environment 1 expected-body])
+ (synthesis.function/abstraction [actual-environment 1 actual-body])])))
+
+(def: (apply-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ (do {@ random.monad}
+ [abstraction (:: @ map (|>> synthesis.constant)
+ (random.and (random.unicode 1)
+ (random.unicode 1)))
+ inputs (random.list ..scope-arity (scenario context))]
+ (wrap [(synthesis.function/apply [abstraction (list@map product.left inputs)])
+ (synthesis.function/apply [abstraction (list@map product.right inputs)])])))
+
+(def: (function-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ ($_ random.either
+ (..abstraction-scenario scenario context)
+ (..apply-scenario scenario context)
+ ))
+
+(def: (control-scenario scenario context)
+ (-> (Scenario Synthesis) (Scenario Synthesis))
+ ($_ random.either
+ (..branch-scenario scenario context)
+ (..loop-scenario scenario context)
+ (..function-scenario scenario context)
+ ))
+
+(def: (scenario context)
+ (Scenario Synthesis)
+ ($_ random.either
+ (..primitive-scenario context)
+ (..structure-scenario context)
+ (..control-scenario (..with-redundancy
+ (..control-scenario
+ (..with-redundancy
+ ..structure-scenario)))
+ context)
+ ))
+
+(def: default
+ Context
+ {#redundants 0
+ #necessary (dictionary.new n.hash)})
+
+(def: #export test
+ Test
+ (<| (_.covering /._)
+ ($_ _.and
+ (do random.monad
+ [[expected input] (..scenario ..default)]
+ (_.cover [/.optimization]
+ (|> (/.optimization input)
+ (!expect (^multi (#try.Success actual)
+ (:: synthesis.equivalence = expected actual))))))
+ )))