aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux48
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux56
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux68
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/synthesis.lux30
-rw-r--r--stdlib/source/test/lux/control/parser/cli.lux124
-rw-r--r--stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/loop.lux2
6 files changed, 182 insertions, 146 deletions
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 44b627b6c..33e94f89a 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux
@@ -50,42 +50,46 @@
(phase@wrap (#/.Primitive (..primitive analysis')))
(#///analysis.Structure structure)
- (case structure
- (#///analysis.Variant variant)
- (do phase.monad
- [valueS (phase' (get@ #///analysis.value variant))]
- (wrap (/.variant (set@ #///analysis.value valueS variant))))
+ (/.with-currying? false
+ (case structure
+ (#///analysis.Variant variant)
+ (do phase.monad
+ [valueS (phase' (get@ #///analysis.value variant))]
+ (wrap (/.variant (set@ #///analysis.value valueS variant))))
- (#///analysis.Tuple tuple)
- (|> tuple
- (monad.map phase.monad phase')
- (phase@map (|>> /.tuple))))
+ (#///analysis.Tuple tuple)
+ (|> tuple
+ (monad.map phase.monad phase')
+ (phase@map (|>> /.tuple)))))
(#///analysis.Reference reference)
(phase@wrap (#/.Reference reference))
(#///analysis.Case inputA branchesAB+)
- (/case.synthesize phase branchesAB+ archive inputA)
+ (/.with-currying? false
+ (/case.synthesize phase branchesAB+ archive inputA))
(^ (///analysis.no-op value))
(phase' value)
(#///analysis.Apply _)
- (/function.apply phase archive analysis)
+ (/.with-currying? false
+ (/function.apply phase archive analysis))
(#///analysis.Function environmentA bodyA)
(/function.abstraction phase environmentA archive bodyA)
(#///analysis.Extension name args)
- (function (_ state)
- (|> (//extension.apply archive phase [name args])
- (phase.run' state)
- (case> (#try.Success output)
- (#try.Success output)
-
- (#try.Failure _)
- (<| (phase.run' state)
- (do {@ phase.monad}
- [argsS+ (monad.map @ phase' args)]
- (wrap (#/.Extension [name argsS+])))))))
+ (/.with-currying? false
+ (function (_ state)
+ (|> (//extension.apply archive phase [name args])
+ (phase.run' state)
+ (case> (#try.Success output)
+ (#try.Success output)
+
+ (#try.Failure _)
+ (|> args
+ (monad.map phase.monad phase')
+ (phase@map (|>> [name] #/.Extension))
+ (phase.run' state))))))
)))
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 890722aeb..358a63c31 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,19 +3,20 @@
[abstract
["." monad (#+ do)]]
[control
- [pipe (#+ case>)]
["." exception (#+ exception:)]]
[data
["." maybe]
["." text
["%" format (#+ format)]]
+ [number
+ ["n" nat]]
[collection
["." list ("#@." functor monoid fold)]]]]
["." // #_
["#." loop (#+ Transform)]
["//#" /// #_
["#." analysis (#+ Environment Analysis)]
- ["/" synthesis (#+ Path Synthesis Operation Phase)]
+ ["/" synthesis (#+ Path Abstraction Synthesis Operation Phase)]
[///
[arity (#+ Arity)]
["#." reference
@@ -52,11 +53,14 @@
(with-expansions [<apply> (as-is (/.function/apply [funcS argsS]))]
(case funcS
(^ (/.function/abstraction functionS))
- (do @
- [locals /.locals]
- (wrap (|> functionS
- (//loop.optimization locals argsS)
- (maybe.default <apply>))))
+ (if (n.= (get@ #/.arity functionS)
+ (list.size argsS))
+ (do @
+ [locals /.locals]
+ (wrap (|> functionS
+ (//loop.optimization true locals argsS)
+ (maybe.default <apply>))))
+ (wrap <apply>))
(^ (/.function/apply [funcS' argsS']))
(wrap (/.function/apply [funcS' (list@compose argsS' argsS)]))
@@ -211,13 +215,31 @@
(def: #export (abstraction phase environment archive bodyA)
(-> Phase Environment Phase)
(do {@ phase.monad}
- [bodyS (/.with-locals 2
- (phase archive bodyA))]
- (case bodyS
- (^ (/.function/abstraction [env' down-arity' bodyS']))
- (|> bodyS'
- (grow env')
- (:: @ map (|>> [environment (inc down-arity')] /.function/abstraction)))
-
- _
- (wrap (/.function/abstraction [environment 1 bodyS])))))
+ [currying? /.currying?
+ bodyS (/.with-currying? true
+ (/.with-locals 2
+ (phase archive bodyA)))
+ abstraction (: (Operation Abstraction)
+ (case bodyS
+ (^ (/.function/abstraction [env' down-arity' bodyS']))
+ (|> bodyS'
+ (grow env')
+ (:: @ map (function (_ body)
+ {#/.environment environment
+ #/.arity (inc down-arity')
+ #/.body body})))
+
+ _
+ (wrap {#/.environment environment
+ #/.arity 1
+ #/.body bodyS})))]
+ (wrap (if currying?
+ (/.function/abstraction abstraction)
+ (case (//loop.optimization false 1 (list) abstraction)
+ (#.Some loop-body)
+ (/.function/abstraction {#/.environment environment
+ #/.arity (get@ #/.arity abstraction)
+ #/.body loop-body})
+
+ #.None
+ (/.function/abstraction abstraction))))))
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 b4a43ce23..9301292f8 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
@@ -23,14 +23,18 @@
(-> Register (-> Register Register))
(|>> dec (n.+ offset)))
-(def: (variable-optimization offset environment variable)
- (-> Register Environment (Transform Variable))
+(def: (variable-optimization true-loop? offset environment variable)
+ (-> Bit Register Environment (Transform Variable))
(case variable
(^ (variable.self))
- #.None
+ (if true-loop?
+ #.None
+ (#.Some variable))
(#variable.Foreign register)
- (list.nth register environment)
+ (if true-loop?
+ (list.nth register environment)
+ (#.Some variable))
(#variable.Local register)
(#.Some (#variable.Local (register-optimization offset register)))))
@@ -58,8 +62,8 @@
_
(#.Some path))))
-(def: (body-optimization offset scope-environment arity expr)
- (-> Register Environment Arity (Transform Synthesis))
+(def: (body-optimization true-loop? offset scope-environment arity expr)
+ (-> Bit Register Environment Arity (Transform Synthesis))
(loop [return? true
expr expr]
(case expr
@@ -83,7 +87,9 @@
(#/.Reference reference)
(case reference
(^ (#reference.Variable (variable.self)))
- #.None
+ (if true-loop?
+ #.None
+ (#.Some expr))
(^ (reference.constant constant))
(#.Some expr)
@@ -92,9 +98,11 @@
(#.Some (#/.Reference (reference.local (register-optimization offset register))))
(^ (reference.foreign register))
- (|> scope-environment
- (list.nth register)
- (maybe@map (|>> #reference.Variable #/.Reference))))
+ (if true-loop?
+ (|> scope-environment
+ (list.nth register)
+ (maybe@map (|>> /.variable)))
+ (#.Some expr)))
(^ (/.branch/case [input path]))
(do maybe.monad
@@ -137,35 +145,35 @@
(^ (/.function/abstraction [environment arity body]))
(do {@ maybe.monad}
- [environment' (monad.map @ (variable-optimization offset scope-environment)
+ [environment' (monad.map @ (variable-optimization true-loop? offset scope-environment)
environment)]
(wrap (/.function/abstraction [environment' arity body])))
(^ (/.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'])))))
+ (with-expansions [<application> (as-is (do !
+ [abstraction' (recur false abstraction)]
+ (wrap (/.function/apply [abstraction' arguments']))))]
+ (case abstraction
+ (^ (#/.Reference (#reference.Variable (variable.self))))
+ (if (and return?
+ (n.= arity (list.size arguments)))
+ (wrap (/.loop/recur arguments'))
+ (if true-loop?
+ #.None
+ <application>))
+
+ _
+ <application>)))
(#/.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))
+(def: #export (optimization true-loop? offset inits functionS)
+ (-> Bit Register (List Synthesis) Abstraction (Maybe Synthesis))
+ (|> (get@ #/.body functionS)
+ (body-optimization true-loop? offset (get@ #/.environment functionS) (get@ #/.arity functionS))
+ (maybe@map (|>> [offset inits] /.loop/scope))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
index 06f84d90d..c010b05c3 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
@@ -27,10 +27,13 @@
["." reference (#+ Reference)
["." variable (#+ Register Variable)]]]])
-(type: #export Resolver (Dictionary Variable Variable))
+(type: #export Resolver
+ (Dictionary Variable Variable))
(type: #export State
- {#locals Nat})
+ {#locals Nat
+ ## https://en.wikipedia.org/wiki/Currying
+ #currying? Bit})
(def: #export fresh-resolver
Resolver
@@ -38,7 +41,8 @@
(def: #export init
State
- {#locals 0})
+ {#locals 0
+ #currying? false})
(type: #export Primitive
(#Bit Bit)
@@ -180,25 +184,17 @@
(def: #export unit Text "")
-(template [<name> <type> <tag>]
- [(def: #export (<name> value)
+(template [<with> <query> <tag> <type>]
+ [(def: #export (<with> value)
(-> <type> (All [a] (-> (Operation a) (Operation a))))
- (extension.temporary (set@ <tag> value)))]
+ (extension.temporary (set@ <tag> value)))
- [with-locals Nat #locals]
- )
-
-(def: #export (with-abstraction arity resolver)
- (-> Arity Resolver
- (All [a] (-> (Operation a) (Operation a))))
- (extension.with-state {#locals arity}))
-
-(template [<name> <tag> <type>]
- [(def: #export <name>
+ (def: #export <query>
(Operation <type>)
(extension.read (get@ <tag>)))]
- [locals #locals Nat]
+ [with-locals locals #locals Nat]
+ [with-currying? currying? #currying? Bit]
)
(def: #export with-new-local
diff --git a/stdlib/source/test/lux/control/parser/cli.lux b/stdlib/source/test/lux/control/parser/cli.lux
index 210a1b5b5..2c781e4fc 100644
--- a/stdlib/source/test/lux/control/parser/cli.lux
+++ b/stdlib/source/test/lux/control/parser/cli.lux
@@ -1,76 +1,82 @@
(.module:
[lux #*
- [data
- ["." name]]
- ["M" abstract/monad (#+ Monad do)]
["_" test (#+ Test)]
- ["r" math/random]
+ [abstract
+ [monad (#+ do)]]
[control
- pipe
["." try]
- ["p" parser]]
+ ["<>" parser]]
[data
[number
["n" nat ("#@." decimal)]]
["." text ("#@." equivalence)]
[collection
- ["." list]]]]
+ ["." list]]]
+ [math
+ ["." random]]]
{1
["." /]})
+(template: (!expect <pattern> <value>)
+ (case <value>
+ <pattern>
+ true
+
+ _
+ false))
+
(def: #export test
Test
- (<| (_.context (name.module (name-of /._)))
- (do {@ r.monad}
- [num-args (|> r.nat (:: @ map (n.% 10)))
- #let [gen-arg (:: @ map n@encode r.nat)]
- yes gen-arg
- #let [gen-ignore (r.filter (|>> (text@= yes) not)
- (r.unicode 5))]
- no gen-ignore
- pre-ignore (r.list 5 gen-ignore)
- post-ignore (r.list 5 gen-ignore)]
+ (<| (_.covering /._)
+ (_.with-cover [/.Parser])
+ (do {@ random.monad}
+ [expected (:: @ map n@encode random.nat)
+ #let [random-dummy (random.filter (|>> (text@= expected) not)
+ (random.unicode 5))]
+ dummy random-dummy
+ short (random.unicode 1)
+ long (random.unicode 2)
+ pre-ignore (random.list 5 random-dummy)
+ post-ignore (random.list 5 random-dummy)]
($_ _.and
- (_.test "Can read any argument."
- (|> (/.run /.any (list yes))
- (case> (#try.Failure _)
- #0
-
- (#try.Success arg)
- (text@= arg yes))))
- (_.test "Can test tokens."
- (and (|> (/.run (/.this yes) (list yes))
- (case> (#try.Failure _)
- #0
-
- (#try.Success _)
- #1))
- (|> (/.run (/.this yes) (list no))
- (case> (#try.Failure _)
- #1
-
- (#try.Success _)
- #0))))
- (_.test "Can use custom token parsers."
- (|> (/.run (/.parse n@decode) (list yes))
- (case> (#try.Failure _)
- #0
-
- (#try.Success parsed)
- (text@= (n@encode parsed)
- yes))))
- (_.test "Can query if there are any more inputs."
- (and (|> (/.run /.end (list))
- (case> (#try.Success []) #1 _ #0))
- (|> (/.run (p.not /.end) (list yes))
- (case> (#try.Success []) #0 _ #1))))
- (_.test "Can parse CLI input anywhere."
- (|> (/.run (|> (/.somewhere (/.this yes))
- (p.before (p.some /.any)))
- (list.concat (list pre-ignore (list yes) post-ignore)))
- (case> (#try.Failure _)
- #0
-
- (#try.Success _)
- #1)))
+ (_.cover [/.run /.any]
+ (|> (/.run /.any (list expected))
+ (!expect (^multi (#try.Success actual)
+ (text@= expected actual)))))
+ (_.cover [/.parse]
+ (|> (/.run (/.parse n@decode) (list expected))
+ (!expect (^multi (#try.Success actual)
+ (text@= expected
+ (n@encode actual))))))
+ (_.cover [/.this]
+ (and (|> (/.run (/.this expected) (list expected))
+ (!expect (#try.Success _)))
+ (|> (/.run (/.this expected) (list dummy))
+ (!expect (#try.Failure _)))))
+ (_.cover [/.somewhere]
+ (|> (/.run (|> (/.somewhere (/.this expected))
+ (<>.before (<>.some /.any)))
+ (list.concat (list pre-ignore (list expected) post-ignore)))
+ (!expect (#try.Success _))))
+ (_.cover [/.end]
+ (and (|> (/.run /.end (list))
+ (!expect (#try.Success _)))
+ (|> (/.run (<>.not /.end) (list expected))
+ (!expect (#try.Failure _)))))
+ (_.cover [/.named]
+ (|> (/.run (/.named dummy /.any) (list dummy expected))
+ (!expect (^multi (#try.Success actual)
+ (text@= expected actual)))))
+ (_.cover [/.parameter]
+ (and (|> (/.run (/.parameter [short long] /.any)
+ (list short expected))
+ (!expect (^multi (#try.Success actual)
+ (text@= expected actual))))
+ (|> (/.run (/.parameter [short long] /.any)
+ (list long expected))
+ (!expect (^multi (#try.Success actual)
+ (text@= expected actual))))
+ (|> (/.run (/.parameter [short long] /.any)
+ (list dummy expected))
+ (!expect (#try.Failure _)))))
))))
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
index adb98ba3a..e42e139d1 100644
--- 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
@@ -273,7 +273,7 @@
(random.list arity))
[_ [expected iteration]] (..scenario expected-offset arity 0)]
(_.cover [/.Transform /.optimization /.register-optimization]
- (case (/.optimization expected-offset expected-inits
+ (case (/.optimization true expected-offset expected-inits
{#//.environment (|> expected-offset
list.indices
(list@map (|>> #variable.Local)))