aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--stdlib/source/lux/compiler/default/evaluation.lux2
-rw-r--r--stdlib/source/lux/compiler/default/init.lux2
-rw-r--r--stdlib/source/lux/compiler/default/phase/analysis.lux22
-rw-r--r--stdlib/source/lux/compiler/default/phase/synthesis.lux234
-rw-r--r--stdlib/source/lux/compiler/default/phase/synthesis/case.lux15
-rw-r--r--stdlib/source/lux/compiler/default/phase/synthesis/expression.lux59
-rw-r--r--stdlib/source/lux/compiler/default/phase/synthesis/function.lux277
-rw-r--r--stdlib/source/lux/compiler/default/phase/translation/scheme/case.jvm.lux2
-rw-r--r--stdlib/test/test/lux/compiler/default/phase/synthesis/case.lux6
-rw-r--r--stdlib/test/test/lux/compiler/default/phase/synthesis/function.lux17
-rw-r--r--stdlib/test/test/lux/compiler/default/phase/synthesis/primitive.lux2
-rw-r--r--stdlib/test/test/lux/compiler/default/phase/synthesis/structure.lux4
12 files changed, 427 insertions, 215 deletions
diff --git a/stdlib/source/lux/compiler/default/evaluation.lux b/stdlib/source/lux/compiler/default/evaluation.lux
index 3fb1a9984..ea76624df 100644
--- a/stdlib/source/lux/compiler/default/evaluation.lux
+++ b/stdlib/source/lux/compiler/default/evaluation.lux
@@ -29,7 +29,7 @@
[exprA (type.with-type type
(expressionA.compile exprC))]
(phase.lift (do error.Monad<Error>
- [exprS (|> exprA expressionS.synthesize (phase.run synthesis-state))]
+ [exprS (|> exprA expressionS.phase (phase.run synthesis-state))]
(phase.run translation-state
(do phase.Monad<Operation>
[exprO (translate exprS)]
diff --git a/stdlib/source/lux/compiler/default/init.lux b/stdlib/source/lux/compiler/default/init.lux
index 947dc9d4b..96464ed2a 100644
--- a/stdlib/source/lux/compiler/default/init.lux
+++ b/stdlib/source/lux/compiler/default/init.lux
@@ -85,7 +85,7 @@
{#statement.analysis {#statement.state analysis-state
#statement.phase expressionA.compile}
#statement.synthesis {#statement.state synthesis-state
- #statement.phase expressionS.synthesize}
+ #statement.phase expressionS.phase}
#statement.translation {#statement.state translation-state
#statement.phase translate}}]))
diff --git a/stdlib/source/lux/compiler/default/phase/analysis.lux b/stdlib/source/lux/compiler/default/phase/analysis.lux
index 7663f6950..dde9f4e9a 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis.lux
@@ -112,19 +112,23 @@
(#..Function (list))
(#..Apply value)))
-(def: #export (apply [func args])
+(def: #export (apply [abstraction inputs])
(-> (Application Analysis) Analysis)
- (list/fold (function (_ arg func) (#Apply arg func)) func args))
+ (list/fold (function (_ input abstraction')
+ (#Apply input abstraction'))
+ abstraction
+ inputs))
(def: #export (application analysis)
(-> Analysis (Application Analysis))
- (case analysis
- (#Apply head func)
- (let [[func' tail] (application func)]
- [func' (#.Cons head tail)])
-
- _
- [analysis (list)]))
+ (loop [abstraction analysis
+ inputs (list)]
+ (case abstraction
+ (#Apply input next)
+ (recur next (#.Cons input inputs))
+
+ _
+ [abstraction inputs])))
(do-template [<name> <tag>]
[(template: #export (<name> content)
diff --git a/stdlib/source/lux/compiler/default/phase/synthesis.lux b/stdlib/source/lux/compiler/default/phase/synthesis.lux
index bf60c9798..da5cad094 100644
--- a/stdlib/source/lux/compiler/default/phase/synthesis.lux
+++ b/stdlib/source/lux/compiler/default/phase/synthesis.lux
@@ -1,15 +1,18 @@
(.module:
[lux (#- i64 Scope)
- [control [monad (#+ do)]]
+ [control
+ [monad (#+ do)]
+ [equivalence (#+ Equivalence)]
+ ["ex" exception (#+ exception:)]]
[data
- [error (#+ Error)]
- ["." text
+ [bit ("bit/." Equivalence<Bit>)]
+ ["." text ("text/." Equivalence<Text>)
format]
[collection
[list ("list/." Functor<List>)]
["." dictionary (#+ Dictionary)]]]]
["." //
- ["." analysis (#+ Environment Arity Analysis)]
+ ["." analysis (#+ Environment Arity Composite Analysis)]
["." extension (#+ Extension)]
[//
["." reference (#+ Register Variable Reference)]]])
@@ -17,10 +20,7 @@
(type: #export Resolver (Dictionary Variable Variable))
(type: #export State
- {#scope-arity Arity
- #resolver Resolver
- #direct? Bit
- #locals Nat})
+ {#locals Nat})
(def: #export fresh-resolver
Resolver
@@ -28,10 +28,7 @@
(def: #export init
State
- {#scope-arity 0
- #resolver fresh-resolver
- #direct? #0
- #locals 0})
+ {#locals 0})
(type: #export Primitive
(#Bit Bit)
@@ -39,10 +36,6 @@
(#F64 Frac)
(#Text Text))
-(type: #export (Structure a)
- (#Variant (analysis.Variant a))
- (#Tuple (analysis.Tuple a)))
-
(type: #export Side
(Either Nat Nat))
@@ -96,7 +89,7 @@
(type: #export #rec Synthesis
(#Primitive Primitive)
- (#Structure (Structure Synthesis))
+ (#Structure (Composite Synthesis))
(#Reference Reference)
(#Control (Control Synthesis))
(#Extension (Extension Synthesis)))
@@ -157,9 +150,15 @@
(<tag> content))]
[path/bind #..Bind]
+ [path/then #..Then]
+ )
+
+(do-template [<name> <tag>]
+ [(template: #export (<name> left right)
+ (<tag> [left right]))]
+
[path/alt #..Alt]
[path/seq #..Seq]
- [path/then #..Then]
)
(type: #export Abstraction
@@ -170,41 +169,24 @@
(def: #export unit Text "")
-(do-template [<name> <value>]
- [(def: #export <name>
- (All [a] (-> (Operation a) (Operation a)))
- (extension.temporary (set@ #direct? <value>)))]
-
- [indirectly #0]
- [directly #1]
- )
-
(do-template [<name> <type> <tag>]
[(def: #export (<name> value)
(-> <type> (All [a] (-> (Operation a) (Operation a))))
(extension.temporary (set@ <tag> value)))]
- [with-scope-arity Arity #scope-arity]
- [with-resolver Resolver #resolver]
[with-locals Nat #locals]
)
(def: #export (with-abstraction arity resolver)
(-> Arity Resolver
(All [a] (-> (Operation a) (Operation a))))
- (extension.with-state {#scope-arity arity
- #resolver resolver
- #direct? #1
- #locals arity}))
+ (extension.with-state {#locals arity}))
(do-template [<name> <tag> <type>]
[(def: #export <name>
(Operation <type>)
(extension.read (get@ <tag>)))]
- [scope-arity #scope-arity Arity]
- [resolver #resolver Resolver]
- [direct? #direct? Bit]
[locals #locals Nat]
)
@@ -230,8 +212,8 @@
<tag>
content))]
- [variant #..Variant]
- [tuple #..Tuple]
+ [variant #analysis.Variant]
+ [tuple #analysis.Tuple]
)
(do-template [<name> <tag>]
@@ -272,6 +254,59 @@
[function/apply #..Function #..Apply]
)
+(def: #export (%path' %then value)
+ (All [a] (-> (Format a) (Format (Path' a))))
+ (case value
+ #Pop
+ "_"
+
+ (#Test primitive)
+ (format "(? "
+ (case primitive
+ (#Bit value)
+ (%b value)
+
+ (#I64 value)
+ (%i (.int value))
+
+ (#F64 value)
+ (%f value)
+
+ (#Text value)
+ (%t value))
+ ")")
+
+ (#Access access)
+ (case access
+ (#Side side)
+ (case side
+ (#.Left lefts)
+ (format "(" (%n lefts) " #0" ")")
+
+ (#.Right lefts)
+ (format "(" (%n lefts) " #1" ")"))
+
+ (#Member member)
+ (case member
+ (#.Left lefts)
+ (format "[" (%n lefts) " #0" "]")
+
+ (#.Right lefts)
+ (format "[" (%n lefts) " #1" "]")))
+
+ (#Bind register)
+ (format "(@ " (%n register) ")")
+
+ (#Alt left right)
+ (format "(| " (%path' %then left) " " (%path' %then right) ")")
+
+ (#Seq left right)
+ (format "(& " (%path' %then left) " " (%path' %then right) ")")
+
+ (#Then then)
+ (|> (%then then)
+ (text.enclose ["(! " ")"]))))
+
(def: #export (%synthesis value)
(Format Synthesis)
(case value
@@ -283,7 +318,7 @@
[..text %t])
(^ (..i64 value))
- (%n (.nat value))
+ (%i (.int value))
(^ (..variant [lefts right? content]))
(|> (%synthesis content)
@@ -295,6 +330,121 @@
(list/map %synthesis)
(text.join-with " ")
(text.enclose ["[" "]"]))
-
- _
- "???"))
+
+ (#Reference reference)
+ (reference.%reference reference)
+
+ (#Control control)
+ (case control
+ (#Function function)
+ (case function
+ (#Abstraction [environment arity body])
+ (|> (%synthesis body)
+ (format (%n arity) " ")
+ (format (|> environment
+ (list/map reference.%variable)
+ (text.join-with " ")
+ (text.enclose ["[" "]"]))
+ " ")
+ (text.enclose ["(" ")"]))
+
+ (#Apply func args)
+ (|> (list/map %synthesis args)
+ (text.join-with " ")
+ (format (%synthesis func) " ")
+ (text.enclose ["(" ")"])))
+
+ ## (%path' %synthesis ...)
+ ## (#Branch branch)
+ ## (#Loop loop)
+ _
+ "???")
+
+ (#Extension [name args])
+ (|> (list/map %synthesis args)
+ (text.join-with " ")
+ (format (%t name))
+ (text.enclose ["(" ")"]))))
+
+(def: #export %path
+ (Format Path)
+ (%path' %synthesis))
+
+(structure: #export _ (Equivalence Primitive)
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag> <eq> <format>]
+ [(<tag> reference') (<tag> sample')]
+ (<eq> reference' sample'))
+ ([#Bit bit/= %b]
+ [#F64 f/= %f]
+ [#Text text/= %t])
+
+ [(#I64 reference') (#I64 sample')]
+ (i/= (.int reference') (.int sample'))
+
+ _
+ false)))
+
+(structure: #export _ (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])
+
+ _
+ false)))
+
+(structure: #export (Equivalence<Path'> Equivalence<a>)
+ (All [a] (-> (Equivalence a) (Equivalence (Path' a))))
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [#Pop #Pop]
+ true
+
+ (^template [<tag> <equivalence>]
+ [(<tag> reference') (<tag> sample')]
+ (:: <equivalence> = reference' sample'))
+ ([#Test Equivalence<Primitive>]
+ [#Access Equivalence<Access>]
+ [#Then Equivalence<a>])
+
+ [(#Bind reference') (#Bind sample')]
+ (n/= reference' sample')
+
+ (^template [<tag>]
+ [(<tag> leftR rightR) (<tag> leftS rightS)]
+ (and (= leftR leftS)
+ (= rightR rightS)))
+ ([#Alt]
+ [#Seq])
+
+ _
+ false)))
+
+(structure: #export _ (Equivalence Synthesis)
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag> <equivalence>]
+ [(<tag> reference') (<tag> sample')]
+ (:: <equivalence> = reference' sample'))
+ ([#Primitive Equivalence<Primitive>])
+
+ _
+ false)))
+
+(def: #export Equivalence<Path>
+ (Equivalence Path)
+ (Equivalence<Path'> Equivalence<Synthesis>))
diff --git a/stdlib/source/lux/compiler/default/phase/synthesis/case.lux b/stdlib/source/lux/compiler/default/phase/synthesis/case.lux
index c9de46ac9..e9e941a30 100644
--- a/stdlib/source/lux/compiler/default/phase/synthesis/case.lux
+++ b/stdlib/source/lux/compiler/default/phase/synthesis/case.lux
@@ -43,11 +43,7 @@
[#analysis.Text #//.Text]))
(#analysis.Bind register)
- (<| (do ///.Monad<Operation>
- [arity //.scope-arity])
- (:: @ map (|>> (#//.Seq (#//.Bind (if (function.nested? arity)
- (n/+ (dec arity) register)
- register)))))
+ (<| (:: ///.Monad<Operation> map (|>> (#//.Seq (#//.Bind register))))
//.with-new-local
thenC)
@@ -140,14 +136,9 @@
_
(do @
- [arity //.scope-arity
- headB/bodyS (//.with-new-local
+ [headB/bodyS (//.with-new-local
(synthesize^ headB/bodyA))]
- (wrap (//.branch/let [inputS
- (if (function.nested? arity)
- (n/+ (dec arity) inputR)
- inputR)
- headB/bodyS])))))
+ (wrap (//.branch/let [inputS inputR headB/bodyS])))))
<if>
(as-is (^or (^ [[(analysis.pattern/bit #1) thenA]
diff --git a/stdlib/source/lux/compiler/default/phase/synthesis/expression.lux b/stdlib/source/lux/compiler/default/phase/synthesis/expression.lux
index 4a5f2979c..6cdd9b6fc 100644
--- a/stdlib/source/lux/compiler/default/phase/synthesis/expression.lux
+++ b/stdlib/source/lux/compiler/default/phase/synthesis/expression.lux
@@ -6,7 +6,7 @@
["." maybe]
[collection
["." list ("list/." Functor<List>)]
- ["dict" dictionary (#+ Dictionary)]]]]
+ ["." dictionary (#+ Dictionary)]]]]
["." // (#+ Synthesis Phase)
["." function]
["." case]
@@ -36,62 +36,39 @@
[#analysis.Int #//.I64]
[#analysis.Rev #//.I64])))
-(def: #export (synthesize analysis)
+(def: #export (phase analysis)
Phase
(case analysis
(#analysis.Primitive analysis')
(operation/wrap (#//.Primitive (..primitive analysis')))
- (#analysis.Structure composite)
- (case (analysis.variant analysis)
- (#.Some variant)
+ (#analysis.Structure structure)
+ (case structure
+ (#analysis.Variant variant)
(do ///.Monad<Operation>
- [valueS (synthesize (get@ #analysis.value variant))]
- (wrap (#//.Structure (#//.Variant (set@ #analysis.value valueS variant)))))
-
- _
- (do ///.Monad<Operation>
- [tupleS (monad.map @ synthesize (analysis.tuple analysis))]
- (wrap (#//.Structure (#//.Tuple tupleS)))))
+ [valueS (phase (get@ #analysis.value variant))]
+ (wrap (//.variant (set@ #analysis.value valueS variant))))
+ (#analysis.Tuple tuple)
+ (|> tuple
+ (monad.map ///.Monad<Operation> phase)
+ (:: ///.Monad<Operation> map (|>> //.tuple))))
+
(#analysis.Reference reference)
- (case reference
- (#reference.Constant constant)
- (operation/wrap (#//.Reference reference))
-
- (#reference.Variable var)
- (do ///.Monad<Operation>
- [resolver //.resolver]
- (case var
- (#reference.Local register)
- (do @
- [arity //.scope-arity]
- (wrap (if (function.nested? arity)
- (if (n/= 0 register)
- (|> (dec arity)
- (list.n/range 1)
- (list/map (|>> //.variable/local))
- [(//.variable/local 0)]
- //.function/apply)
- (#//.Reference (#reference.Variable (function.adjust arity #0 var))))
- (#//.Reference (#reference.Variable var)))))
-
- (#reference.Foreign register)
- (wrap (|> resolver (dict.get var) (maybe.default var) #reference.Variable #//.Reference)))))
+ (operation/wrap (#//.Reference reference))
(#analysis.Case inputA branchesAB+)
- (case.synthesize (|>> synthesize //.indirectly) inputA branchesAB+)
+ (case.synthesize phase inputA branchesAB+)
(^ (analysis.no-op value))
- (synthesize value)
+ (phase value)
(#analysis.Apply _)
- (function.apply (|>> synthesize //.indirectly) analysis)
+ (function.apply phase analysis)
(#analysis.Function environmentA bodyA)
- (function.function synthesize environmentA bodyA)
+ (function.abstraction phase environmentA bodyA)
(#analysis.Extension name args)
- (extension.apply (|>> synthesize //.indirectly)
- [name args])
+ (extension.apply phase [name args])
))
diff --git a/stdlib/source/lux/compiler/default/phase/synthesis/function.lux b/stdlib/source/lux/compiler/default/phase/synthesis/function.lux
index 3c89ae063..196d959ed 100644
--- a/stdlib/source/lux/compiler/default/phase/synthesis/function.lux
+++ b/stdlib/source/lux/compiler/default/phase/synthesis/function.lux
@@ -1,120 +1,211 @@
(.module:
- [lux (#- function)
+ [lux #*
[control
- ["." monad (#+ do)]]
+ ["." monad (#+ do)]
+ ["ex" exception (#+ exception:)]]
[data
["." maybe]
+ ["." text
+ format]
[collection
["." list ("list/." Functor<List> Monoid<List> Fold<List>)]
["dict" dictionary (#+ Dictionary)]]]]
- ["." // (#+ Synthesis Operation Phase)
+ ["." // (#+ Path Synthesis Operation Phase)
["." loop (#+ Transform)]
- ["/." //
+ ["/." // ("operation/." Monad<Operation>)
["." analysis (#+ Environment Arity Analysis)]
[//
- ["." reference (#+ Variable)]]]])
+ ["." reference (#+ Register Variable)]]]])
-(def: #export nested?
- (-> Arity Bit)
- (n/> 1))
+(exception: #export (cannot-find-foreign-variable-in-environment {foreign Register} {environment Environment})
+ (ex.report ["Foreign" (%n foreign)]
+ ["Environment" (|> environment
+ (list/map reference.%variable)
+ (text.join-with " "))]))
-(def: #export (adjust up-arity after? var)
- (-> Arity Bit Variable Variable)
- (case var
- (#reference.Local register)
- (if (and after? (n/>= up-arity register))
- (#reference.Local (n/+ (dec up-arity) register))
- var)
+(def: arity-arguments
+ (-> Arity (List Synthesis))
+ (|>> dec
+ (list.n/range 1)
+ (list/map (|>> //.variable/local))))
- _
- var))
-
-(def: (unfold apply)
- (-> Analysis [Analysis (List Analysis)])
- (loop [apply apply
- args (list)]
- (case apply
- (#analysis.Apply arg func)
- (recur func (#.Cons arg args))
+(template: #export (self-reference)
+ (//.variable/local 0))
- _
- [apply args])))
+(def: (expanded-nested-self-reference arity)
+ (-> Arity Synthesis)
+ (//.function/apply [(..self-reference) (arity-arguments arity)]))
-(def: #export (apply synthesize)
+(def: #export (apply phase)
(-> Phase Phase)
- (.function (_ exprA)
- (let [[funcA argsA] (unfold exprA)]
+ (function (_ exprA)
+ (let [[funcA argsA] (analysis.application exprA)]
(do ///.Monad<Operation>
- [funcS (synthesize funcA)
- argsS (monad.map @ synthesize argsA)
- locals //.locals]
- (case funcS
- (^ (//.function/abstraction functionS))
- (wrap (|> functionS
- (loop.loop (get@ #//.environment functionS) locals argsS)
- (maybe.default (//.function/apply [funcS argsS]))))
+ [funcS (phase funcA)
+ argsS (monad.map @ phase argsA)
+ ## locals //.locals
+ ]
+ (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/apply [funcS' argsS']))
+ (wrap (//.function/apply [funcS' (list/compose argsS' argsS)]))
- (^ (//.function/apply [funcS' argsS']))
- (wrap (//.function/apply [funcS' (list/compose argsS' argsS)]))
+ _
+ (wrap <apply>)))))))
+(def: (find-foreign environment register)
+ (-> Environment Register (Operation Variable))
+ (case (list.nth register environment)
+ (#.Some aliased)
+ (operation/wrap aliased)
+
+ #.None
+ (///.throw cannot-find-foreign-variable-in-environment [register environment])))
+
+(def: (grow-path grow path)
+ (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path))
+ (case path
+ (#//.Bind register)
+ (operation/wrap (#//.Bind (inc register)))
+
+ (^template [<tag>]
+ (<tag> left right)
+ (do ///.Monad<Operation>
+ [left' (grow-path grow left)
+ right' (grow-path grow right)]
+ (wrap (<tag> left' right'))))
+ ([#//.Alt] [#//.Alt])
+
+ (#//.Then thenS)
+ (|> thenS
+ grow
+ (operation/map (|>> #//.Then)))
+
+ _
+ (operation/wrap path)))
+
+(def: (grow-sub-environment super sub)
+ (-> Environment Environment (Operation Environment))
+ (monad.map ///.Monad<Operation>
+ (function (_ variable)
+ (case variable
+ (#reference.Local register)
+ (operation/wrap variable)
+
+ (#reference.Foreign register)
+ (find-foreign super register)))
+ sub))
+
+(def: (grow environment expression)
+ (-> Environment Synthesis (Operation Synthesis))
+ (case expression
+ (#//.Structure structure)
+ (case structure
+ (#analysis.Variant [lefts right? subS])
+ (|> subS
+ (grow environment)
+ (operation/map (|>> [lefts right?] //.variant)))
+
+ (#analysis.Tuple membersS+)
+ (|> membersS+
+ (monad.map ///.Monad<Operation> (grow environment))
+ (operation/map (|>> //.tuple))))
+
+ (^ (..self-reference))
+ (operation/wrap (//.function/apply [expression (list (//.variable/local 1))]))
+
+ (#//.Reference reference)
+ (case reference
+ (#reference.Variable variable)
+ (case variable
+ (#reference.Local register)
+ (operation/wrap (//.variable/local (inc register)))
+
+ (#reference.Foreign register)
+ (|> register
+ (find-foreign environment)
+ (operation/map (|>> //.variable))))
+
+ (#reference.Constant constant)
+ (operation/wrap expression))
+
+ (#//.Control control)
+ (case control
+ (#//.Branch branch)
+ (case branch
+ (#//.Let [inputS register bodyS])
+ (do ///.Monad<Operation>
+ [inputS' (grow environment inputS)
+ bodyS' (grow environment bodyS)]
+ (wrap (//.branch/let [inputS' (inc register) bodyS'])))
+
+ (#//.If [testS thenS elseS])
+ (do ///.Monad<Operation>
+ [testS' (grow environment testS)
+ thenS' (grow environment thenS)
+ elseS' (grow environment elseS)]
+ (wrap (//.branch/if [testS' thenS' elseS'])))
+
+ (#//.Case [inputS pathS])
+ (do ///.Monad<Operation>
+ [inputS' (grow environment inputS)
+ pathS' (grow-path (grow environment) pathS)]
+ (wrap (//.branch/case [inputS' pathS']))))
+
+ (#//.Loop loop)
+ (case loop
+ (#//.Scope [start initsS+ iterationS])
+ (do ///.Monad<Operation>
+ [initsS+' (monad.map @ (grow environment) initsS+)
+ iterationS' (grow environment iterationS)]
+ (wrap (//.loop/scope [start initsS+' iterationS'])))
+
+ (#//.Recur argumentsS+)
+ (|> argumentsS+
+ (monad.map ///.Monad<Operation> (grow environment))
+ (operation/map (|>> //.loop/recur))))
+
+ (#//.Function function)
+ (case function
+ (#//.Abstraction [_env _arity _body])
+ (do ///.Monad<Operation>
+ [_env' (grow-sub-environment environment _env)]
+ (wrap (//.function/abstraction [_env' _arity _body])))
+
+ (#//.Apply funcS argsS+)
+ (case funcS
+ (^ (//.function/apply [(..self-reference) pre-argsS+]))
+ (operation/wrap (//.function/apply [(..self-reference)
+ (list/compose pre-argsS+ argsS+)]))
+
_
- (wrap (//.function/apply [funcS argsS])))))))
+ (do ///.Monad<Operation>
+ [funcS' (grow environment funcS)
+ argsS+' (monad.map @ (grow environment) argsS+)]
+ (wrap (//.function/apply [funcS' argsS+']))))))
+
+ (#//.Extension name argumentsS+)
+ (|> argumentsS+
+ (monad.map ///.Monad<Operation> (grow environment))
+ (operation/map (|>> (#//.Extension name))))
-(def: (prepare up down body)
- (-> Arity Arity Synthesis Synthesis)
- (if (nested? up)
- body
- (maybe.default body (loop.recursion down body))))
+ _
+ (operation/wrap expression)))
-(def: #export (function synthesize environment body)
+(def: #export (abstraction phase environment bodyA)
(-> Phase Environment Analysis (Operation Synthesis))
(do ///.Monad<Operation>
- [direct? //.direct?
- arity //.scope-arity
- resolver //.resolver
- #let [function-arity (if direct?
- (inc arity)
- 1)
- up-environment (if (nested? arity)
- (list/map (.function (_ closure)
- (case (dict.get closure resolver)
- (#.Some resolved)
- (adjust arity #1 resolved)
-
- #.None
- (adjust arity #0 closure)))
- environment)
- environment)
- down-environment (: (List Variable)
- (case environment
- #.Nil
- (list)
-
- _
- (|> environment
- list.size
- list.indices
- (list/map (|>> #reference.Foreign)))))
- resolver' (if (and (nested? function-arity)
- direct?)
- (list/fold (.function (_ [from to] resolver')
- (dict.put from to resolver'))
- //.fresh-resolver
- (list.zip2 down-environment up-environment))
- (list/fold (.function (_ var resolver')
- (dict.put var var resolver'))
- //.fresh-resolver
- down-environment))]
- bodyS (//.with-abstraction function-arity resolver'
- (synthesize body))]
+ [bodyS (phase bodyA)]
(case bodyS
(^ (//.function/abstraction [env' down-arity' bodyS']))
- (let [arity' (inc down-arity')]
- (|> (prepare function-arity arity' bodyS')
- [up-environment arity'] //.function/abstraction
- wrap))
-
+ (|> bodyS'
+ (grow env')
+ (:: @ map (|>> [environment (inc down-arity')] //.function/abstraction)))
+
_
- (|> (prepare function-arity 1 bodyS)
- [up-environment 1] //.function/abstraction
- wrap))))
+ (wrap (//.function/abstraction [environment 1 bodyS])))))
diff --git a/stdlib/source/lux/compiler/default/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/case.jvm.lux
index 1d9415a99..4a963d507 100644
--- a/stdlib/source/lux/compiler/default/phase/translation/scheme/case.jvm.lux
+++ b/stdlib/source/lux/compiler/default/phase/translation/scheme/case.jvm.lux
@@ -142,7 +142,7 @@
[synthesis.member/right runtime.product//right inc])
(^template [<tag> <computation>]
- (^ (<tag> [leftP rightP]))
+ (^ (<tag> leftP rightP))
(do ////.Monad<Operation>
[leftO (pattern-matching' translate leftP)
rightO (pattern-matching' translate rightP)]
diff --git a/stdlib/test/test/lux/compiler/default/phase/synthesis/case.lux b/stdlib/test/test/lux/compiler/default/phase/synthesis/case.lux
index f3c3b9d2e..2084ee46b 100644
--- a/stdlib/test/test/lux/compiler/default/phase/synthesis/case.lux
+++ b/stdlib/test/test/lux/compiler/default/phase/synthesis/case.lux
@@ -31,7 +31,7 @@
(list)]])]]
(test "Dummy variables created to mask expressions get eliminated during synthesis."
(|> maskA
- expression.synthesize
+ expression.phase
(phase.run [bundle.empty //.init])
(error/map (//primitive.corresponds? maskedA))
(error.default #0))))))
@@ -49,7 +49,7 @@
(list)]])]]
(test "Can detect and reify simple 'let' expressions."
(|> letA
- expression.synthesize
+ expression.phase
(phase.run [bundle.empty //.init])
(case> (^ (#error.Success (//.branch/let [inputS registerS outputS])))
(and (n/= registerA registerS)
@@ -77,7 +77,7 @@
(analysis.control/case [inputA [elseB (list thenB)]]))]]
(test "Can detect and reify simple 'if' expressions."
(|> ifA
- expression.synthesize
+ expression.phase
(phase.run [bundle.empty //.init])
(case> (^ (#error.Success (//.branch/if [inputS thenS elseS])))
(and (//primitive.corresponds? inputA inputS)
diff --git a/stdlib/test/test/lux/compiler/default/phase/synthesis/function.lux b/stdlib/test/test/lux/compiler/default/phase/synthesis/function.lux
index fae0e0fdf..133048936 100644
--- a/stdlib/test/test/lux/compiler/default/phase/synthesis/function.lux
+++ b/stdlib/test/test/lux/compiler/default/phase/synthesis/function.lux
@@ -105,9 +105,8 @@
(#analysis.Reference (reference.local chosen))
(|> chosen (n/+ (dec arity)) #reference.Local)])))))
-(context: "Function definition."
- (<| (seed 13007429814532219492)
- ## (times 100)
+(context: "Abstraction."
+ (<| (times 100)
(do @
[[arity//constant function//constant prediction//constant] constant-function
[arity//environment function//environment prediction//environment] function-with-environment
@@ -115,7 +114,7 @@
($_ seq
(test "Nested functions will get folded together."
(|> function//constant
- expression.synthesize
+ expression.phase
(phase.run [bundle.empty //.init])
(case> (^ (#error.Success (//.function/abstraction [environment arity output])))
(and (n/= arity//constant arity)
@@ -125,7 +124,7 @@
(n/= 0 arity//constant))))
(test "Folded functions provide direct access to environment variables."
(|> function//environment
- expression.synthesize
+ expression.phase
(phase.run [bundle.empty //.init])
(case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (reference.variable output))])))
(and (n/= arity//environment arity)
@@ -135,7 +134,7 @@
#0)))
(test "Folded functions properly offset local variables."
(|> function//local
- expression.synthesize
+ expression.phase
(phase.run [bundle.empty //.init])
(case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (reference.variable output))])))
(and (n/= arity//local arity)
@@ -145,7 +144,7 @@
#0)))
))))
-(context: "Function application."
+(context: "Application."
(<| (times 100)
(do @
[arity (|> r.nat (:: @ map (|>> (n/% 10) (n/max 1))))
@@ -154,7 +153,7 @@
($_ seq
(test "Can synthesize function application."
(|> (analysis.apply [funcA argsA])
- expression.synthesize
+ expression.phase
(phase.run [bundle.empty //.init])
(case> (^ (#error.Success (//.function/apply [funcS argsS])))
(and (//primitive.corresponds? funcA funcS)
@@ -165,7 +164,7 @@
#0)))
(test "Function application on no arguments just synthesizes to the function itself."
(|> (analysis.apply [funcA (list)])
- expression.synthesize
+ expression.phase
(phase.run [bundle.empty //.init])
(case> (#error.Success funcS)
(//primitive.corresponds? funcA funcS)
diff --git a/stdlib/test/test/lux/compiler/default/phase/synthesis/primitive.lux b/stdlib/test/test/lux/compiler/default/phase/synthesis/primitive.lux
index fbe190a93..0a55fbcf6 100644
--- a/stdlib/test/test/lux/compiler/default/phase/synthesis/primitive.lux
+++ b/stdlib/test/test/lux/compiler/default/phase/synthesis/primitive.lux
@@ -80,7 +80,7 @@
(~~ (do-template [<desc> <analysis> <synthesis> <sample>]
[(test (format "Can synthesize " <desc> ".")
(|> (#analysis.Primitive (<analysis> <sample>))
- expression.synthesize
+ expression.phase
(phase.run [bundle.empty //.init])
(case> (#error.Success (#//.Primitive (<synthesis> value)))
(is? <sample> value)
diff --git a/stdlib/test/test/lux/compiler/default/phase/synthesis/structure.lux b/stdlib/test/test/lux/compiler/default/phase/synthesis/structure.lux
index 90fd155b0..a78aa1a09 100644
--- a/stdlib/test/test/lux/compiler/default/phase/synthesis/structure.lux
+++ b/stdlib/test/test/lux/compiler/default/phase/synthesis/structure.lux
@@ -31,7 +31,7 @@
($_ seq
(test "Can synthesize variants."
(|> (analysis.sum-analysis size tagA memberA)
- expression.synthesize
+ expression.phase
(phase.run [bundle.empty //.init])
(case> (#error.Success (#//.Structure (#//.Variant [leftsS right?S valueS])))
(let [tagS (if right?S (inc leftsS) leftsS)]
@@ -51,7 +51,7 @@
($_ seq
(test "Can synthesize tuple."
(|> (analysis.product-analysis membersA)
- expression.synthesize
+ expression.phase
(phase.run [bundle.empty //.init])
(case> (#error.Success (#//.Structure (#//.Tuple membersS)))
(and (n/= size (list.size membersS))