aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/case.lux3
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/loop.lux25
-rw-r--r--stdlib/source/lux/control/io.lux16
-rw-r--r--stdlib/source/lux/control/parser/binary.lux5
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/analysis.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux33
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux376
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/synthesis.lux202
-rw-r--r--stdlib/source/lux/tool/compiler/reference/variable.lux5
-rw-r--r--stdlib/source/test/lux/control.lux2
-rw-r--r--stdlib/source/test/lux/control/parser/binary.lux359
-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/loop.lux293
13 files changed, 985 insertions, 340 deletions
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/case.lux b/lux-jvm/source/luxc/lang/translation/jvm/case.lux
index 23f84ad4e..421f413a0 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/case.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/case.lux
@@ -23,8 +23,7 @@
[archive (#+ Archive)]]
[language
[lux
- ["." synthesis (#+ Path Synthesis)
- ["#/." case]]]]]]]
+ ["." synthesis (#+ Path Synthesis)]]]]]]
[luxc
[lang
[host
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/loop.lux b/lux-jvm/source/luxc/lang/translation/jvm/loop.lux
index 10fb23cbd..27a7d58f9 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/loop.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/loop.lux
@@ -8,7 +8,7 @@
[number
["n" nat]]
[collection
- ["." list ("#/." functor monoid)]]]
+ ["." list ("#@." functor monoid)]]]
[tool
[compiler
["." phase]
@@ -25,11 +25,11 @@
["_" inst]]]]]
["." //])
-(def: (invariant? register changeS)
+(def: (invariant? expected actual)
(-> Register Synthesis Bit)
- (case changeS
- (^ (synthesis.variable/local var))
- (n.= register var)
+ (case actual
+ (^ (synthesis.variable/local actual))
+ (n.= expected actual)
_
false))
@@ -38,24 +38,25 @@
(Generator (List Synthesis))
(do {@ phase.monad}
[[@begin start] generation.anchor
- #let [end (|> argsS list.size dec (n.+ start))
- pairs (list.zip2 (list.n/range start end)
- argsS)]
+ #let [pairs (|> argsS
+ list.enumerate
+ (list@map (function (_ [register argument])
+ [(n.+ start register) argument])))]
## It may look weird that first I compile the values separately,
## and then I compile the stores/allocations.
## It must be done that way in order to avoid a potential bug.
## Let's say that you'll recur with 2 expressions: X and Y.
## If Y depends on the value of X, and you don't compile values
## and stores separately, then by the time Y is evaluated, it
- ## will refer to the new value of X, instead of the old value, as
- ## should be the case.
+ ## will refer to the new value of X, instead of the old value, and
+ ## shouldn't be the case.
valuesI+ (monad.map @ (function (_ [register argS])
(: (Operation Inst)
(if (invariant? register argS)
(wrap function.identity)
(translate archive argS))))
pairs)
- #let [storesI+ (list/map (function (_ [register argS])
+ #let [storesI+ (list@map (function (_ [register argS])
(: Inst
(if (invariant? register argS)
function.identity
@@ -73,7 +74,7 @@
iterationI (generation.with-anchor [@begin start]
(translate archive iterationS))
#let [initializationI (|> (list.enumerate initsI+)
- (list/map (function (_ [register initI])
+ (list@map (function (_ [register initI])
(|>> initI
(_.ASTORE (n.+ start register)))))
_.fuse)]]
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)))
+ )))