aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux.lux2
-rw-r--r--stdlib/source/lux/control/parser/json.lux82
-rw-r--r--stdlib/source/lux/data/format/json.lux8
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/analysis.lux29
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux15
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/synthesis.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/reference/variable.lux3
-rw-r--r--stdlib/source/poly/lux/data/format/json.lux40
-rw-r--r--stdlib/source/test/lux/control.lux8
-rw-r--r--stdlib/source/test/lux/control/parser/json.lux158
-rw-r--r--stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux569
12 files changed, 696 insertions, 232 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index bda5f60d9..e76d59d1a 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -1814,7 +1814,7 @@
(return (wrap-meta (form$ (list (tag$ ["lux" "Frac"]) (frac$ value)))))
[_ [_ (#Text value)]]
- (return (wrap-meta (form$ (list (tag$ ["lux" "Text"]) (text$ value)))))
+ (return (untemplate-text value))
[#0 [_ (#Tag [module name])]]
(return (wrap-meta (form$ (list (tag$ ["lux" "Tag"]) (tuple$ (list (text$ module) (text$ name)))))))
diff --git a/stdlib/source/lux/control/parser/json.lux b/stdlib/source/lux/control/parser/json.lux
index ed1620627..48006855b 100644
--- a/stdlib/source/lux/control/parser/json.lux
+++ b/stdlib/source/lux/control/parser/json.lux
@@ -30,8 +30,8 @@
(exception: #export empty-input)
-(def: #export (run json parser)
- (All [a] (-> JSON (Parser a) (Try a)))
+(def: #export (run parser json)
+ (All [a] (-> (Parser a) JSON (Try a)))
(case (//.run parser (list json))
(#try.Success [remainder output])
(case remainder
@@ -39,93 +39,97 @@
(#try.Success output)
_
- (exception.throw unconsumed-input remainder))
+ (exception.throw ..unconsumed-input remainder))
(#try.Failure error)
(#try.Failure error)))
-(def: #export (fail error)
- (All [a] (-> Text (Parser a)))
- (function (_ inputs)
- (#try.Failure error)))
-
(def: #export any
{#.doc "Just returns the JSON input without applying any logic."}
(Parser JSON)
(<| (function (_ inputs))
(case inputs
#.Nil
- (exception.throw empty-input [])
+ (exception.throw ..empty-input [])
(#.Cons head tail)
(#try.Success [tail head]))))
+(exception: #export (unexpected-value {value JSON})
+ (exception.report
+ ["Value" (/.format value)]))
+
(template [<name> <type> <tag> <desc>]
[(def: #export <name>
{#.doc (code.text ($_ text@compose "Reads a JSON value as " <desc> "."))}
(Parser <type>)
(do //.monad
- [head any]
+ [head ..any]
(case head
(<tag> value)
(wrap value)
_
- (fail ($_ text@compose "JSON value is not " <desc> ".")))))]
+ (//.fail (exception.construct ..unexpected-value [head])))))]
- [null Any #/.Null "null"]
- [boolean Bit #/.Boolean "boolean"]
- [number Frac #/.Number "number"]
- [string Text #/.String "string"]
+ [null /.Null #/.Null "null"]
+ [boolean /.Boolean #/.Boolean "boolean"]
+ [number /.Number #/.Number "number"]
+ [string /.String #/.String "string"]
)
-(template [<test> <check> <type> <eq> <encoder> <tag> <desc>]
+(exception: #export [a] (value-mismatch {reference JSON} {sample JSON})
+ (exception.report
+ ["Reference" (/.format reference)]
+ ["Sample" (/.format sample)]))
+
+(template [<test> <check> <type> <equivalence> <tag> <desc>]
[(def: #export (<test> test)
{#.doc (code.text ($_ text@compose "Asks whether a JSON value is a " <desc> "."))}
(-> <type> (Parser Bit))
(do //.monad
- [head any]
+ [head ..any]
(case head
(<tag> value)
- (wrap (:: <eq> = test value))
+ (wrap (:: <equivalence> = test value))
_
- (fail ($_ text@compose "JSON value is not " <desc> ".")))))
+ (//.fail (exception.construct ..unexpected-value [head])))))
(def: #export (<check> test)
{#.doc (code.text ($_ text@compose "Ensures a JSON value is a " <desc> "."))}
(-> <type> (Parser Any))
(do //.monad
- [head any]
+ [head ..any]
(case head
(<tag> value)
- (if (:: <eq> = test value)
+ (if (:: <equivalence> = test value)
(wrap [])
- (fail ($_ text@compose "Value mismatch: " (|> test <encoder>) " =/= " (|> value <encoder>))))
+ (//.fail (exception.construct ..value-mismatch [(<tag> test) (<tag> value)])))
_
- (fail ($_ text@compose "JSON value is not a " <desc> ".")))))]
+ (//.fail (exception.construct ..unexpected-value [head])))))]
- [boolean? boolean! Bit bit.equivalence (<| /.format #/.Boolean) #/.Boolean "boolean"]
- [number? number! Frac frac.equivalence (:: frac.decimal encode) #/.Number "number"]
- [string? string! Text text.equivalence text.encode #/.String "string"]
+ [boolean? boolean! /.Boolean bit.equivalence #/.Boolean "boolean"]
+ [number? number! /.Number frac.equivalence #/.Number "number"]
+ [string? string! /.String text.equivalence #/.String "string"]
)
(def: #export (nullable parser)
(All [a] (-> (Parser a) (Parser (Maybe a))))
- (//.or null
+ (//.or ..null
parser))
(def: #export (array parser)
{#.doc "Parses a JSON array."}
(All [a] (-> (Parser a) (Parser a)))
(do //.monad
- [head any]
+ [head ..any]
(case head
(#/.Array values)
(case (//.run parser (row.to-list values))
(#try.Failure error)
- (fail error)
+ (//.fail error)
(#try.Success [remainder output])
(case remainder
@@ -133,16 +137,16 @@
(wrap output)
_
- (fail (exception.construct unconsumed-input remainder))))
+ (//.fail (exception.construct ..unconsumed-input remainder))))
_
- (fail (text@compose "JSON value is not an array: " (/.format head))))))
+ (//.fail (exception.construct ..unexpected-value [head])))))
(def: #export (object parser)
{#.doc "Parses a JSON object. Use this with the 'field' combinator."}
(All [a] (-> (Parser a) (Parser a)))
(do //.monad
- [head any]
+ [head ..any]
(case head
(#/.Object kvs)
(case (|> kvs
@@ -152,7 +156,7 @@
list.concat
(//.run parser))
(#try.Failure error)
- (fail error)
+ (//.fail error)
(#try.Success [remainder output])
(case remainder
@@ -160,10 +164,10 @@
(wrap output)
_
- (fail (exception.construct unconsumed-input remainder))))
+ (//.fail (exception.construct ..unconsumed-input remainder))))
_
- (fail (text@compose "JSON value is not an object: " (/.format head))))))
+ (//.fail (exception.construct ..unexpected-value [head])))))
(def: #export (field field-name parser)
{#.doc "Parses a field inside a JSON object. Use this inside the 'object' combinator."}
@@ -177,7 +181,7 @@
(#try.Success [inputs' output])
(#try.Success [inputs'' _])
- (exception.throw unconsumed-input inputs'')
+ (exception.throw ..unconsumed-input inputs'')
(#try.Failure error)
(#try.Failure error))
@@ -187,15 +191,15 @@
output])))
#.Nil
- (exception.throw empty-input [])
+ (exception.throw ..empty-input [])
_
- (exception.throw unconsumed-input inputs))))
+ (exception.throw ..unconsumed-input inputs))))
(def: #export dictionary
{#.doc "Parses a dictionary-like JSON object."}
(All [a] (-> (Parser a) (Parser (Dictionary Text a))))
(|>> (//.and ..string)
//.some
- object
+ ..object
(//@map (dictionary.from-list text.hash))))
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index 11aa27d3c..e0975d02d 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -154,7 +154,9 @@
[get-object #Object Object "objects"]
)
-(structure: #export equivalence (Equivalence JSON)
+(structure: #export equivalence
+ (Equivalence JSON)
+
(def: (= x y)
(case [x y]
[#Null #Null]
@@ -361,6 +363,8 @@
(-> Any (Parser JSON))
($_ p.or null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
-(structure: #export codec (Codec Text JSON)
+(structure: #export codec
+ (Codec Text JSON)
+
(def: encode ..format)
(def: decode (l.run (json~' []))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
index 71009473a..f3dc89993 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
@@ -39,14 +39,16 @@
(#Frac Frac)
(#Text Text))
-(type: #export Tag Nat)
+(type: #export Tag
+ Nat)
(type: #export (Variant a)
{#lefts Nat
#right? Bit
#value a})
-(type: #export (Tuple a) (List a))
+(type: #export (Tuple a)
+ (List a))
(type: #export (Composite a)
(#Variant (Variant a))
@@ -186,21 +188,26 @@
[control/case #..Case]
)
-(template [<name> <type> <tag>]
+(template: #export (unit)
+ (#..Primitive #..Unit))
+
+(template [<name> <tag>]
[(template: #export (<name> value)
(#..Primitive (<tag> value)))]
- [bit Bit #..Bit]
- [nat Nat #..Nat]
- [int Int #..Int]
- [rev Rev #..Rev]
- [frac Frac #..Frac]
- [text Text #..Text]
+ [bit #..Bit]
+ [nat #..Nat]
+ [int #..Int]
+ [rev #..Rev]
+ [frac #..Frac]
+ [text #..Text]
)
-(type: #export (Abstraction c) [Environment Arity c])
+(type: #export (Abstraction c)
+ [Environment Arity c])
-(type: #export (Application c) [c (List c)])
+(type: #export (Application c)
+ [c (List c)])
(def: (last? size tag)
(-> Nat Tag Bit)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux
index 3e2bbd321..3c80060c2 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux
@@ -184,12 +184,6 @@
(#///analysis.Reference (///reference.local <output>))]
(list)])
-(def: #export (synthesize-masking synthesize archive input @variable @output)
- (-> Phase Archive Synthesis Register Register (Operation Synthesis))
- (if (n.= @variable @output)
- (///@wrap input)
- (..synthesize-case synthesize archive input (!masking @variable @output))))
-
(def: #export (synthesize-let synthesize archive input @variable body)
(-> Phase Archive Synthesis Register Analysis (Operation Synthesis))
(do ///.monad
@@ -197,6 +191,12 @@
(synthesize archive body))]
(wrap (/.branch/let [input @variable body]))))
+(def: #export (synthesize-masking synthesize archive input @variable @output)
+ (-> Phase Archive Synthesis Register Register (Operation Synthesis))
+ (if (n.= @variable @output)
+ (///@wrap input)
+ (..synthesize-let synthesize archive input @variable (#///analysis.Reference (///reference.local @output)))))
+
(def: #export (synthesize-if synthesize archive test then else)
(-> Phase Archive Synthesis Analysis Analysis (Operation Synthesis))
(do ///.monad
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 358a63c31..896ec2161 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
@@ -5,7 +5,7 @@
[control
["." exception (#+ exception:)]]
[data
- ["." maybe]
+ ["." maybe ("#@." functor)]
["." text
["%" format (#+ format)]]
[number
@@ -59,6 +59,19 @@
[locals /.locals]
(wrap (|> functionS
(//loop.optimization true locals argsS)
+ (maybe@map (: (-> Synthesis Synthesis)
+ (function (_ synthesis)
+ (case synthesis
+ (^ (<| /.loop/scope [start inits]
+ /.loop/scope [start' inits']
+ output))
+ (if (and (n.= start start')
+ (list.empty? inits'))
+ (/.loop/scope [start inits output])
+ synthesis)
+
+ _
+ synthesis))))
(maybe.default <apply>))))
(wrap <apply>))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
index c010b05c3..590653281 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
@@ -397,7 +397,7 @@
(#Extension [name args])
(|> (list@map %synthesis args)
(text.join-with " ")
- (format (%.text name))
+ (format (%.text name) " ")
(text.enclose ["(" ")"]))))
(def: #export %path
diff --git a/stdlib/source/lux/tool/compiler/reference/variable.lux b/stdlib/source/lux/tool/compiler/reference/variable.lux
index e0c814e8d..cea605e93 100644
--- a/stdlib/source/lux/tool/compiler/reference/variable.lux
+++ b/stdlib/source/lux/tool/compiler/reference/variable.lux
@@ -12,7 +12,8 @@
[text
["%" format (#+ Format)]]]])
-(type: #export Register Nat)
+(type: #export Register
+ Nat)
(type: #export Variable
(#Local Register)
diff --git a/stdlib/source/poly/lux/data/format/json.lux b/stdlib/source/poly/lux/data/format/json.lux
index e23d5648c..d3a32b27a 100644
--- a/stdlib/source/poly/lux/data/format/json.lux
+++ b/stdlib/source/poly/lux/data/format/json.lux
@@ -56,22 +56,25 @@
(def: low-mask Nat (|> 1 (i64.left-shift 32) dec))
(def: high-mask Nat (|> low-mask (i64.left-shift 32)))
-(structure: nat-codec (codec.Codec JSON Nat)
+(structure: nat-codec
+ (codec.Codec JSON Nat)
+
(def: (encode input)
(let [high (|> input (i64.and high-mask) (i64.logic-right-shift 32))
low (i64.and low-mask input)]
(#/.Array (row (|> high .int int.frac #/.Number)
(|> low .int int.frac #/.Number)))))
- (def: (decode input)
- (<| (</>.run input)
- </>.array
- (do p.monad
- [high </>.number
- low </>.number])
- (wrap (n.+ (|> high frac.int .nat (i64.left-shift 32))
- (|> low frac.int .nat))))))
+ (def: decode
+ (</>.run (</>.array
+ (do p.monad
+ [high </>.number
+ low </>.number]
+ (wrap (n.+ (|> high frac.int .nat (i64.left-shift 32))
+ (|> low frac.int .nat))))))))
-(structure: int-codec (codec.Codec JSON Int)
+(structure: int-codec
+ (codec.Codec JSON Int)
+
(def: encode (|>> .nat (:: nat-codec encode)))
(def: decode
(|>> (:: nat-codec decode) (:: e.functor map .int))))
@@ -85,7 +88,8 @@
(#.Some value) (writer value))))
(structure: qty-codec
- (All [unit] (codec.Codec JSON (unit.Qty unit)))
+ (All [unit]
+ (codec.Codec JSON (unit.Qty unit)))
(def: encode
(|>> unit.out (:: ..int-codec encode)))
@@ -322,11 +326,9 @@
#dictionary (Dictionary Text Frac)})
(derived: (..codec Record)))}
- (with-gensyms [g!inputs]
- (wrap (list (` (: (codec.Codec /.JSON (~ inputT))
- (structure (def: (~' encode)
- (..codec//encode (~ inputT)))
- (def: ((~' decode) (~ g!inputs))
- ((~! </>.run) (~ g!inputs)
- (..codec//decode (~ inputT))))
- )))))))
+ (wrap (list (` (: (codec.Codec /.JSON (~ inputT))
+ (structure (def: (~' encode)
+ (..codec//encode (~ inputT)))
+ (def: (~' decode)
+ ((~! </>.run) (..codec//decode (~ inputT))))
+ ))))))
diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux
index bad67d90a..80a94be6f 100644
--- a/stdlib/source/test/lux/control.lux
+++ b/stdlib/source/test/lux/control.lux
@@ -22,9 +22,10 @@
["#." parser
["#/." analysis]
["#/." binary]
- ["#/." text]
["#/." cli]
- ["#/." code]]
+ ["#/." code]
+ ["#/." json]
+ ["#/." text]]
["#." pipe]
["#." reader]
["#." region]
@@ -62,9 +63,10 @@
/parser.test
/parser/analysis.test
/parser/binary.test
- /parser/text.test
/parser/cli.test
/parser/code.test
+ /parser/json.test
+ /parser/text.test
))
(def: security
diff --git a/stdlib/source/test/lux/control/parser/json.lux b/stdlib/source/test/lux/control/parser/json.lux
new file mode 100644
index 000000000..dbda12366
--- /dev/null
+++ b/stdlib/source/test/lux/control/parser/json.lux
@@ -0,0 +1,158 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ ["." exception]
+ ["<>" parser]]
+ [data
+ ["." maybe]
+ ["." bit]
+ ["." text]
+ [number
+ ["n" nat]
+ ["." frac]]
+ [collection
+ ["." list ("#@." functor)]
+ ["." set]
+ ["." dictionary]
+ ["." row (#+ row) ("#@." functor)]]
+ [format
+ ["." json]]]
+ [math
+ ["." random (#+ Random)]]]
+ {1
+ ["." /]})
+
+(template: (!expect <pattern> <value>)
+ (case <value>
+ <pattern>
+ true
+
+ _
+ false))
+
+(def: #export test
+ Test
+ (<| (_.covering /._)
+ (_.with-cover [/.Parser])
+ (`` ($_ _.and
+ (do {@ random.monad}
+ [expected (:: @ map (|>> #json.String) (random.unicode 1))]
+ (_.cover [/.run /.any]
+ (|> (/.run /.any expected)
+ (!expect (^multi (#try.Success actual)
+ (:: json.equivalence = expected actual))))))
+ (_.cover [/.null]
+ (|> (/.run /.null #json.Null)
+ (!expect (#try.Success _))))
+ (~~ (template [<query> <test> <check> <random> <json> <equivalence>]
+ [(do {@ random.monad}
+ [expected <random>
+ dummy (|> <random> (random.filter (|>> (:: <equivalence> = expected) not)))]
+ ($_ _.and
+ (_.cover [<query>]
+ (|> (/.run <query> (<json> expected))
+ (!expect (^multi (#try.Success actual)
+ (:: <equivalence> = expected actual)))))
+ (_.cover [<test>]
+ (and (|> (/.run (<test> expected) (<json> expected))
+ (!expect (#try.Success #1)))
+ (|> (/.run (<test> expected) (<json> dummy))
+ (!expect (#try.Success #0)))))
+ (_.cover [<check>]
+ (and (|> (/.run (<check> expected) (<json> expected))
+ (!expect (#try.Success _)))
+ (|> (/.run (<check> expected) (<json> dummy))
+ (!expect (#try.Failure _)))))))]
+
+ [/.boolean /.boolean? /.boolean! random.bit #json.Boolean bit.equivalence]
+ [/.number /.number? /.number! random.frac #json.Number frac.equivalence]
+ [/.string /.string? /.string! (random.unicode 1) #json.String text.equivalence]
+ ))
+ (do {@ random.monad}
+ [expected (random.unicode 1)
+ dummy random.bit]
+ (_.cover [/.unexpected-value]
+ (|> (/.run /.string (#json.Boolean dummy))
+ (!expect (^multi (#try.Failure error)
+ (exception.match? /.unexpected-value error))))))
+ (do {@ random.monad}
+ [expected (random.unicode 1)
+ dummy (|> (random.unicode 1) (random.filter (|>> (:: text.equivalence = expected) not)))]
+ (_.cover [/.value-mismatch]
+ (|> (/.run (/.string! expected) (#json.String dummy))
+ (!expect (^multi (#try.Failure error)
+ (exception.match? /.value-mismatch error))))))
+ (do {@ random.monad}
+ [expected (random.unicode 1)]
+ (_.cover [/.nullable]
+ (and (|> (/.run (/.nullable /.string) #json.Null)
+ (!expect (^multi (#try.Success actual)
+ (:: (maybe.equivalence text.equivalence) = #.None actual))))
+ (|> (/.run (/.nullable /.string) (#json.String expected))
+ (!expect (^multi (#try.Success actual)
+ (:: (maybe.equivalence text.equivalence) = (#.Some expected) actual)))))))
+ (do {@ random.monad}
+ [size (:: @ map (n.% 10) random.nat)
+ expected (|> (random.unicode 1)
+ (random.list size)
+ (:: @ map row.from-list))]
+ (_.cover [/.array]
+ (|> (/.run (/.array (<>.some /.string))
+ (#json.Array (row@map (|>> #json.String) expected)))
+ (!expect (^multi (#try.Success actual)
+ (:: (row.equivalence text.equivalence) = expected (row.from-list actual)))))))
+ (do {@ random.monad}
+ [expected (:: @ map (|>> #json.String) (random.unicode 1))]
+ (_.cover [/.unconsumed-input]
+ (|> (/.run (/.array /.any) (#json.Array (row expected expected)))
+ (!expect (^multi (#try.Failure error)
+ (exception.match? /.unconsumed-input error))))))
+ (_.cover [/.empty-input]
+ (|> (/.run (/.array /.any) (#json.Array (row)))
+ (!expect (^multi (#try.Failure error)
+ (exception.match? /.empty-input error)))))
+ (do {@ random.monad}
+ [expected-boolean random.bit
+ expected-number random.frac
+ expected-string (random.unicode 1)
+ [boolean-field number-field string-field] (|> (random.set text.hash 3 (random.unicode 3))
+ (:: @ map (|>> set.to-list
+ (case> (^ (list boolean-field number-field string-field))
+ [boolean-field number-field string-field]
+
+ _
+ (undefined)))))]
+ (_.cover [/.object /.field]
+ (|> (/.run (/.object ($_ <>.and
+ (/.field boolean-field /.boolean)
+ (/.field number-field /.number)
+ (/.field string-field /.string)))
+ (#json.Object
+ (dictionary.from-list text.hash
+ (list [boolean-field (#json.Boolean expected-boolean)]
+ [number-field (#json.Number expected-number)]
+ [string-field (#json.String expected-string)]))))
+ (!expect (^multi (#try.Success [actual-boolean actual-number actual-string])
+ (and (:: bit.equivalence = expected-boolean actual-boolean)
+ (:: frac.equivalence = expected-number actual-number)
+ (:: text.equivalence = expected-string actual-string)))))))
+ (do {@ random.monad}
+ [size (:: @ map (n.% 10) random.nat)
+ keys (random.list size (random.unicode 1))
+ values (random.list size (random.unicode 1))
+ #let [expected (dictionary.from-list text.hash (list.zip2 keys values))]]
+ (_.cover [/.dictionary]
+ (|> (/.run (/.dictionary /.string)
+ (#json.Object
+ (|> values
+ (list@map (|>> #json.String))
+ (list.zip2 keys)
+ (dictionary.from-list text.hash))))
+ (!expect (^multi (#try.Success actual)
+ (:: (dictionary.equivalence text.equivalence) = expected actual))))))
+ ))))
diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux
index 7350881b1..5b092ce51 100644
--- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux
+++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux
@@ -1,23 +1,23 @@
(.module:
[lux #*
+ ["_" test (#+ Test)]
[abstract
["." monad (#+ do)]]
- [data
- ["." name]]
- ["r" math/random (#+ Random) ("#@." monad)]
- ["_" test (#+ Test)]
[control
- pipe
["." try]]
[data
["." product]
["." maybe]
+ ["." text
+ ["%" format (#+ format)]]
[number
["n" nat]]
[collection
- ["." list ("#@." functor fold)]
+ ["." list ("#@." functor fold monoid)]
["." dictionary (#+ Dictionary)]
- ["." set]]]]
+ ["." set]]]
+ [math
+ ["." random (#+ Random)]]]
["." // #_
["#." primitive]]
{1
@@ -27,164 +27,437 @@
[extension
["#." bundle]]
["/#" //
- ["#." analysis (#+ Analysis)]
- ["#." synthesis (#+ Synthesis)]
+ ["." analysis (#+ Analysis)]
+ ["." synthesis (#+ Synthesis)]
[///
[arity (#+ Arity)]
- ["#." reference
+ ["." reference
["." variable (#+ Variable) ("#@." equivalence)]]
["." phase]
[meta
["." archive]]]]]]]})
-(def: constant-function
- (Random [Arity Analysis Analysis])
- (r.rec
- (function (_ constant-function)
- (do {@ r.monad}
- [function? r.bit]
- (if function?
- (do @
- [[arity bodyA predictionA] constant-function]
- (wrap [(inc arity)
- (#////analysis.Function (list) bodyA)
- predictionA]))
- (do @
- [predictionA //primitive.primitive]
- (wrap [0 predictionA predictionA])))))))
-
-(def: (pick scope-size)
- (-> Nat (Random Nat))
- (|> r.nat (:: r.monad map (n.% scope-size))))
-
-(def: function-with-environment
- (Random [Arity Analysis Variable])
- (do {@ r.monad}
- [num-locals (|> r.nat (:: @ map (|>> (n.% 100) (n.max 10))))
- #let [indices (list.n/range 0 (dec num-locals))
- local-env (list@map (|>> #variable.Local) indices)
- foreign-env (list@map (|>> #variable.Foreign) indices)]
- [arity bodyA predictionA] (: (Random [Arity Analysis Variable])
- (loop [arity 1
- current-env foreign-env]
- (let [current-env/size (list.size current-env)
- resolver (list@fold (function (_ [idx var] resolver)
- (dictionary.put idx var resolver))
- (: (Dictionary Nat Variable)
- (dictionary.new n.hash))
- (list.enumerate current-env))]
- (do @
- [nest? r.bit]
- (if nest?
- (do @
- [num-picks (:: @ map (n.max 1) (pick (inc current-env/size)))
- picks (|> (r.set n.hash num-picks (pick current-env/size))
- (:: @ map set.to-list))
- [arity bodyA predictionA] (recur (inc arity)
- (list@map (function (_ pick)
- (maybe.assume (list.nth pick current-env)))
- picks))
- #let [picked-env (list@map (|>> #variable.Foreign) picks)]]
- (wrap [arity
- (#////analysis.Function picked-env bodyA)
- predictionA]))
- (do @
- [chosen (pick (list.size current-env))]
- (wrap [arity
- (#////analysis.Reference (////reference.foreign chosen))
- (maybe.assume (dictionary.get chosen resolver))])))))))]
- (wrap [arity
- (#////analysis.Function local-env bodyA)
- predictionA])))
-
-(def: local-function
- (Random [Arity Analysis Variable])
- (loop [arity 0
- nest? #1]
- (if nest?
- (do r.monad
- [nest?' r.bit
- [arity' bodyA predictionA] (recur (inc arity) nest?')]
- (wrap [arity'
- (#////analysis.Function (list) bodyA)
- predictionA]))
- (do {@ r.monad}
- [chosen (|> r.nat (:: @ map (|>> (n.% 100) (n.max 2))))]
- (wrap [arity
- (#////analysis.Reference (////reference.local chosen))
- (|> chosen (n.+ (dec arity)) #variable.Local)])))))
+(def: (n-function loop? arity body)
+ (-> Bit Arity Synthesis Synthesis)
+ (synthesis.function/abstraction
+ {#synthesis.environment (list)
+ #synthesis.arity arity
+ #synthesis.body (if loop?
+ (synthesis.loop/scope
+ {#synthesis.start 1
+ #synthesis.inits (list)
+ #synthesis.iteration body})
+ body)}))
+
+(def: (n-abstraction arity body)
+ (-> Arity Analysis Analysis)
+ (list@fold (function (_ arity-1 body)
+ (case arity-1
+ 0 (#analysis.Function (list) body)
+ _ (#analysis.Function ($_ list@compose
+ (list@map (|>> #variable.Foreign)
+ (list.indices arity-1))
+ (list (#variable.Local 1)))
+ body)))
+ body
+ (list.reverse (list.indices arity))))
+
+(template: (!expect <pattern> <value>)
+ (case <value>
+ <pattern>
+ true
+
+ _
+ false))
+
+(type: Circumstance
+ {#loop? Bit
+ #expectation Synthesis
+ #reality Analysis})
+
+(type: Scenario
+ (-> Bit (Random Circumstance)))
+
+(def: (random-unit output?)
+ Scenario
+ (:: random.monad wrap
+ [true
+ (synthesis.text synthesis.unit)
+ (analysis.unit)]))
+
+(template [<name> <random> <synthesis> <analysis>]
+ [(def: (<name> output?)
+ Scenario
+ (do {@ random.monad}
+ [value <random>]
+ (wrap [true
+ (<synthesis> value)
+ (<analysis> value)])))]
+
+ [random-bit random.bit synthesis.bit analysis.bit]
+ [random-nat random.nat (|>> .i64 synthesis.i64) analysis.nat]
+ [random-int random.int (|>> .i64 synthesis.i64) analysis.int]
+ [random-rev random.rev (|>> .i64 synthesis.i64) analysis.rev]
+ [random-frac random.frac synthesis.f64 analysis.frac]
+ [random-text (random.unicode 1) synthesis.text analysis.text]
+ )
+
+(def: (random-primitive output?)
+ Scenario
+ (random.either (random.either (..random-unit output?)
+ (random.either (..random-bit output?)
+ (..random-nat output?)))
+ (random.either (random.either (..random-int output?)
+ (..random-rev output?))
+ (random.either (..random-frac output?)
+ (..random-text output?)))))
+
+(def: (random-variant random-value output?)
+ (-> Scenario Scenario)
+ (do {@ random.monad}
+ [lefts random.nat
+ right? random.bit
+ [loop? expected-value actual-value] (random-value false)]
+ (wrap [loop?
+ (synthesis.variant
+ {#analysis.lefts lefts
+ #analysis.right? right?
+ #analysis.value expected-value})
+ (analysis.variant
+ {#analysis.lefts lefts
+ #analysis.right? right?
+ #analysis.value actual-value})])))
+
+(def: (random-tuple random-value output?)
+ (-> Scenario Scenario)
+ (do {@ random.monad}
+ [[loop?-left expected-left actual-left] (random-value false)
+ [loop?-right expected-right actual-right] (random-value false)]
+ (wrap [(and loop?-left
+ loop?-right)
+ (synthesis.tuple (list expected-left expected-right))
+ (analysis.tuple (list actual-left actual-right))])))
+
+(def: (random-structure random-value output?)
+ (-> Scenario Scenario)
+ ($_ random.either
+ (..random-variant random-value output?)
+ (..random-tuple random-value output?)))
+
+(def: (random-variable arity output?)
+ (-> Arity Scenario)
+ (do {@ random.monad}
+ [register (:: @ map (|>> (n.% arity) inc) random.nat)]
+ (wrap [(not (n.= 0 register))
+ (synthesis.variable/local register)
+ (if (n.= arity register)
+ (#analysis.Reference (reference.local 1))
+ (#analysis.Reference (reference.foreign register)))])))
+
+(def: (random-constant output?)
+ Scenario
+ (do {@ random.monad}
+ [module (random.unicode 1)
+ short (random.unicode 1)]
+ (wrap [true
+ (synthesis.constant [module short])
+ (#analysis.Reference (reference.constant [module short]))])))
+
+(def: (random-reference arity output?)
+ (-> Arity Scenario)
+ (random.either (..random-variable arity output?)
+ (..random-constant output?)))
+
+(def: (random-case arity random-value output?)
+ (-> Arity Scenario Scenario)
+ (do {@ random.monad}
+ [bit-test random.bit
+ i64-test random.nat
+ f64-test random.frac
+ text-test (random.unicode 1)
+ [loop?-input expected-input actual-input] (random-value false)
+ [loop?-output expected-output actual-output] (random-value output?)
+ lefts (|> random.nat (:: @ map (n.% 10)))
+ right? random.bit
+ #let [side|member (if right?
+ (#.Right lefts)
+ (#.Left lefts))]]
+ (wrap [(and loop?-input
+ loop?-output)
+ (synthesis.branch/case [expected-input
+ ($_ synthesis.path/alt
+ (synthesis.path/then expected-output)
+ (synthesis.path/seq (synthesis.path/bit bit-test)
+ (synthesis.path/then expected-output))
+ (synthesis.path/seq (synthesis.path/i64 (.i64 i64-test))
+ (synthesis.path/then expected-output))
+ (synthesis.path/seq (synthesis.path/f64 f64-test)
+ (synthesis.path/then expected-output))
+ (synthesis.path/seq (synthesis.path/text text-test)
+ (synthesis.path/then expected-output))
+ (synthesis.path/seq (synthesis.path/bind (inc arity))
+ (synthesis.path/then expected-output))
+ ($_ synthesis.path/seq
+ (synthesis.path/side side|member)
+ (synthesis.path/bind (inc arity))
+ (synthesis.path/then expected-output))
+ (if right?
+ ($_ synthesis.path/seq
+ (synthesis.path/member side|member)
+ (synthesis.path/bind (inc arity))
+ (synthesis.path/then expected-output))
+ ($_ synthesis.path/seq
+ (synthesis.path/member side|member)
+ (synthesis.path/bind (inc arity))
+ synthesis.path/pop
+ (synthesis.path/then expected-output))))])
+ (#analysis.Case actual-input
+ [{#analysis.when (analysis.pattern/unit)
+ #analysis.then actual-output}
+ (list {#analysis.when (analysis.pattern/bit bit-test)
+ #analysis.then actual-output}
+ {#analysis.when (analysis.pattern/nat (.nat i64-test))
+ #analysis.then actual-output}
+ {#analysis.when (analysis.pattern/frac f64-test)
+ #analysis.then actual-output}
+ {#analysis.when (analysis.pattern/text text-test)
+ #analysis.then actual-output}
+ {#analysis.when (#analysis.Bind 2)
+ #analysis.then actual-output}
+ {#analysis.when (analysis.pattern/variant
+ {#analysis.lefts lefts
+ #analysis.right? right?
+ #analysis.value (#analysis.Bind 2)})
+ #analysis.then actual-output}
+ {#analysis.when (analysis.pattern/tuple
+ (list@compose (list.repeat lefts (analysis.pattern/unit))
+ (if right?
+ (list (analysis.pattern/unit) (#analysis.Bind 2))
+ (list (#analysis.Bind 2) (analysis.pattern/unit)))))
+ #analysis.then actual-output})])])))
+
+(def: (random-let arity random-value output?)
+ (-> Arity Scenario Scenario)
+ (do {@ random.monad}
+ [[loop?-input expected-input actual-input] (random-value false)
+ [loop?-output expected-output actual-output] (random-value output?)]
+ (wrap [(and loop?-input
+ loop?-output)
+ (synthesis.branch/let [expected-input
+ (inc arity)
+ expected-output])
+ (#analysis.Case actual-input
+ [{#analysis.when (#analysis.Bind 2)
+ #analysis.then actual-output}
+ (list)])])))
+
+(def: (random-if random-value output?)
+ (-> Scenario Scenario)
+ (do {@ random.monad}
+ [[loop?-test expected-test actual-test] (random-value false)
+ [loop?-then expected-then actual-then] (random-value output?)
+ [loop?-else expected-else actual-else] (random-value output?)
+ flip? random.bit]
+ (wrap [(and loop?-test
+ loop?-then
+ loop?-else)
+ (synthesis.branch/if [expected-test
+ expected-then
+ expected-else])
+ (if flip?
+ (#analysis.Case actual-test
+ [{#analysis.when (analysis.pattern/bit false)
+ #analysis.then actual-else}
+ (list {#analysis.when (analysis.pattern/bit true)
+ #analysis.then actual-then})])
+ (#analysis.Case actual-test
+ [{#analysis.when (analysis.pattern/bit true)
+ #analysis.then actual-then}
+ (list {#analysis.when (analysis.pattern/bit false)
+ #analysis.then actual-else})]))])))
+
+(def: (random-get random-value output?)
+ (-> Scenario Scenario)
+ (do {@ random.monad}
+ [lefts (|> random.nat (:: @ map (n.% 10)))
+ right? random.bit
+ [loop?-record expected-record actual-record] (random-value false)]
+ (wrap [loop?-record
+ (synthesis.branch/get [(list (if right?
+ (#.Right lefts)
+ (#.Left lefts)))
+ expected-record])
+ (#analysis.Case actual-record
+ [{#analysis.when (analysis.pattern/tuple
+ (list@compose (list.repeat lefts (analysis.pattern/unit))
+ (if right?
+ (list (analysis.pattern/unit) (#analysis.Bind 2))
+ (list (#analysis.Bind 2) (analysis.pattern/unit)))))
+ #analysis.then (#analysis.Reference (reference.local 2))}
+ (list)])])))
+
+(def: (random-branch arity random-value output?)
+ (-> Arity Scenario Scenario)
+ (random.either (random.either (..random-case arity random-value output?)
+ (..random-let arity random-value output?))
+ (random.either (..random-if random-value output?)
+ (..random-get random-value output?))))
+
+(def: (random-recur arity random-value output?)
+ (-> Arity Scenario Scenario)
+ (do {@ random.monad}
+ [resets (random.list arity (random-value false))]
+ (wrap [true
+ (synthesis.loop/recur (list@map (|>> product.right product.left) resets))
+ (analysis.apply [(#analysis.Reference (case arity
+ 1 (reference.local 0)
+ _ (reference.foreign 0)))
+ (list@map (|>> product.right product.right) resets)])])))
+
+(def: (random-scope arity output?)
+ (-> Arity Scenario)
+ (do {@ random.monad}
+ [resets (random.list arity (..random-variable arity output?))
+ [_ expected-output actual-output] (..random-nat output?)]
+ (wrap [(list@fold (function (_ new old)
+ (and new old))
+ true
+ (list@map product.left resets))
+ (synthesis.loop/scope
+ {#synthesis.start (inc arity)
+ #synthesis.inits (list@map (|>> product.right product.left) resets)
+ #synthesis.iteration expected-output})
+ (analysis.apply [(..n-abstraction arity actual-output)
+ (list@map (|>> product.right product.right) resets)])])))
+
+(def: (random-loop arity random-value output?)
+ (-> Arity Scenario Scenario)
+ (if output?
+ ($_ random.either
+ (..random-recur arity random-value output?)
+ (..random-scope arity output?)
+ )
+ (..random-scope arity output?)))
+
+(def: (random-abstraction' output?)
+ Scenario
+ (do {@ random.monad}
+ [[loop?-output expected-output actual-output] (..random-nat output?)
+ arity (|> random.nat (:: @ map (|>> (n.% 5) inc)))
+ #let [environment ($_ list@compose
+ (list@map (|>> #variable.Foreign)
+ (list.indices arity))
+ (list (#variable.Local 1)))]]
+ (wrap [true
+ (synthesis.function/abstraction
+ {#synthesis.environment environment
+ #synthesis.arity 1
+ #synthesis.body (synthesis.loop/scope
+ {#synthesis.start 1
+ #synthesis.inits (list)
+ #synthesis.iteration expected-output})})
+ (#analysis.Function environment
+ actual-output)])))
+
+(def: (random-apply random-value output?)
+ (-> Scenario Scenario)
+ (do {@ random.monad}
+ [[loop?-abstraction expected-abstraction actual-abstraction] (..random-nat output?)
+ arity (|> random.nat (:: @ map (|>> (n.% 5) inc)))
+ inputs (random.list arity (random-value false))]
+ (wrap [(list@fold (function (_ new old)
+ (and new old))
+ loop?-abstraction
+ (list@map product.left inputs))
+ (synthesis.function/apply [expected-abstraction
+ (list@map (|>> product.right product.left) inputs)])
+ (analysis.apply [actual-abstraction
+ (list@map (|>> product.right product.right) inputs)])])))
+
+(def: (random-function random-value output?)
+ (-> Scenario Scenario)
+ (if output?
+ (..random-apply random-value output?)
+ ($_ random.either
+ (..random-abstraction' output?)
+ (..random-apply random-value output?)
+ )))
+
+(def: (random-control arity random-value output?)
+ (-> Arity Scenario Scenario)
+ ($_ random.either
+ (..random-branch arity random-value output?)
+ (..random-loop arity random-value output?)
+ (..random-function random-value output?)
+ ))
+
+(def: (random-extension random-value output?)
+ (-> Scenario Scenario)
+ (do {@ random.monad}
+ [name (random.unicode 1)
+ [loop?-first expected-first actual-first] (random-value false)
+ [loop?-second expected-second actual-second] (random-value false)
+ [loop?-third expected-third actual-third] (random-value false)]
+ (wrap [(and loop?-first
+ loop?-second
+ loop?-third)
+ (#synthesis.Extension name (list expected-first expected-second expected-third))
+ (#analysis.Extension name (list actual-first actual-second actual-third))])))
+
+(def: (random-body arity)
+ (-> Arity Scenario)
+ (function (random-value output?)
+ (random.rec
+ (function (_ _)
+ ($_ random.either
+ (..random-primitive output?)
+ (..random-structure random-value output?)
+ (..random-reference arity output?)
+ (..random-control arity random-value output?)
+ (..random-extension random-value output?))))))
+
+(def: random-abstraction
+ (Random [Synthesis Analysis])
+ (do {@ random.monad}
+ [arity (|> random.nat (:: @ map (|>> (n.% 5) inc)))
+ [loop? expected-body actual-body] (random-body arity true)]
+ (wrap [(..n-function loop? arity expected-body)
+ (..n-abstraction arity actual-body)])))
(def: abstraction
Test
- (do r.monad
- [[arity//constant function//constant prediction//constant] constant-function
- [arity//environment function//environment prediction//environment] function-with-environment
- [arity//local function//local prediction//local] local-function]
- ($_ _.and
- (_.test "Nested functions will get folded together."
- (|> function//constant
- (//.phase archive.empty)
- (phase.run [///bundle.empty ////synthesis.init])
- (case> (^ (#try.Success (////synthesis.function/abstraction [environment arity output])))
- (and (n.= arity//constant arity)
- (//primitive.corresponds? prediction//constant output))
-
- _
- (n.= 0 arity//constant))))
- (_.test "Folded functions provide direct access to environment variables."
- (|> function//environment
- (//.phase archive.empty)
- (phase.run [///bundle.empty ////synthesis.init])
- (case> (^ (#try.Success (////synthesis.function/abstraction [environment arity (#////synthesis.Reference (////reference.variable output))])))
- (and (n.= arity//environment arity)
- (variable@= prediction//environment output))
-
- _
- #0)))
- (_.test "Folded functions properly offset local variables."
- (|> function//local
- (//.phase archive.empty)
- (phase.run [///bundle.empty ////synthesis.init])
- (case> (^ (#try.Success (////synthesis.function/abstraction [environment arity (#////synthesis.Reference (////reference.variable output))])))
- (and (n.= arity//local arity)
- (variable@= prediction//local output))
-
- _
- #0)))
- )))
+ (do random.monad
+ [[expected input] ..random-abstraction]
+ (_.cover [/.abstraction]
+ (|> input
+ (//.phase archive.empty)
+ (phase.run [///bundle.empty synthesis.init])
+ (!expect (^multi (#try.Success actual)
+ (:: synthesis.equivalence = expected actual)))))))
(def: application
Test
- (do {@ r.monad}
- [arity (|> r.nat (:: @ map (|>> (n.% 10) (n.max 1))))
+ (do {@ random.monad}
+ [arity (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1))))
funcA //primitive.primitive
- argsA (r.list arity //primitive.primitive)]
- ($_ _.and
- (_.test "Can synthesize function application."
- (|> (////analysis.apply [funcA argsA])
- (//.phase archive.empty)
- (phase.run [///bundle.empty ////synthesis.init])
- (case> (^ (#try.Success (////synthesis.function/apply [funcS argsS])))
- (and (//primitive.corresponds? funcA funcS)
- (list.every? (product.uncurry //primitive.corresponds?)
- (list.zip2 argsA argsS)))
-
- _
- #0)))
- (_.test "Function application on no arguments just synthesizes to the function itself."
- (|> (////analysis.apply [funcA (list)])
- (//.phase archive.empty)
- (phase.run [///bundle.empty ////synthesis.init])
- (case> (#try.Success funcS)
- (//primitive.corresponds? funcA funcS)
-
- _
- #0)))
- )))
+ argsA (random.list arity //primitive.primitive)]
+ (_.cover [/.apply]
+ (and (|> (analysis.apply [funcA argsA])
+ (//.phase archive.empty)
+ (phase.run [///bundle.empty synthesis.init])
+ (!expect (^multi (^ (#try.Success (synthesis.function/apply [funcS argsS])))
+ (and (//primitive.corresponds? funcA funcS)
+ (list.every? (product.uncurry //primitive.corresponds?)
+ (list.zip2 argsA argsS))))))
+ (|> (analysis.apply [funcA (list)])
+ (//.phase archive.empty)
+ (phase.run [///bundle.empty synthesis.init])
+ (!expect (^multi (#try.Success funcS)
+ (//primitive.corresponds? funcA funcS))))))))
(def: #export test
Test
- (<| (_.context (name.module (name-of /._)))
+ (<| (_.covering /._)
($_ _.and
..abstraction
..application