aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/test
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/test/lux/control/concurrency/frp.lux2
-rw-r--r--stdlib/source/test/lux/control/function/memo.lux2
-rw-r--r--stdlib/source/test/lux/macro/code.lux211
-rw-r--r--stdlib/source/test/lux/target/jvm.lux37
4 files changed, 186 insertions, 66 deletions
diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux
index fe082cda7..4d9632b8c 100644
--- a/stdlib/source/test/lux/control/concurrency/frp.lux
+++ b/stdlib/source/test/lux/control/concurrency/frp.lux
@@ -169,7 +169,7 @@
(list@= (list distint/0 distint/1 distint/2)
actual))))
(let [polling-delay 10
- wiggle-room (n.* 2 polling-delay)
+ wiggle-room (n.* 3 polling-delay)
amount-of-polls 5
total-delay (|> polling-delay
(n.* amount-of-polls)
diff --git a/stdlib/source/test/lux/control/function/memo.lux b/stdlib/source/test/lux/control/function/memo.lux
index d09625d79..564e37a87 100644
--- a/stdlib/source/test/lux/control/function/memo.lux
+++ b/stdlib/source/test/lux/control/function/memo.lux
@@ -50,7 +50,7 @@
Test
(<| (_.covering /._)
(do {@ random.monad}
- [input (|> random.nat (:: @ map (|>> (n.% 5) (n.+ 21))))])
+ [input (|> random.nat (:: @ map (|>> (n.% 5) (n.+ 22))))])
(_.with-cover [/.Memo])
($_ _.and
(_.cover [/.closed /.none]
diff --git a/stdlib/source/test/lux/macro/code.lux b/stdlib/source/test/lux/macro/code.lux
index cc2d8012d..0fc1c24be 100644
--- a/stdlib/source/test/lux/macro/code.lux
+++ b/stdlib/source/test/lux/macro/code.lux
@@ -1,54 +1,177 @@
(.module:
[lux #*
- ["%" data/text/format (#+ format)]
- [abstract/monad (#+ do)]
- ["r" math/random (#+ Random)]
["_" test (#+ Test)]
+ [math
+ ["." random (#+ Random) ("#@." monad)]]
+ [abstract
+ [monad (#+ do)]
+ {[0 #spec]
+ [/
+ ["$." equivalence]]}]
+ [control
+ ["." try (#+ Try)]]
[data
- ["." text ("#@." equivalence)]
+ ["." product]
+ ["." text]
[number
- ["i" int]
- ["f" frac]]]]
+ ["n" nat]]
+ [collection
+ ["." list ("#@." functor)]]]
+ [tool
+ [compiler
+ [language
+ [lux
+ ["." syntax]]]]]]
{1
["." /]})
+(def: random-text
+ (Random Text)
+ (random.ascii/alpha 10))
+
+(def: random-name
+ (Random Name)
+ (random.and ..random-text ..random-text))
+
+(def: (random-sequence random)
+ (All [a] (-> (Random a) (Random (List a))))
+ (do {@ random.monad}
+ [size (|> random.nat (:: @ map (n.% 3)))]
+ (random.list size random)))
+
+(def: (random-record random)
+ (All [a] (-> (Random a) (Random (List [a a]))))
+ (do {@ random.monad}
+ [size (|> random.nat (:: @ map (n.% 3)))]
+ (random.list size (random.and random random))))
+
+(def: random
+ (Random Code)
+ (random.rec
+ (function (_ random)
+ ($_ random.either
+ (random@map /.bit random.bit)
+ (random@map /.nat random.nat)
+ (random@map /.int random.int)
+ (random@map /.rev random.rev)
+ (random@map /.frac random.safe-frac)
+ (random@map /.text ..random-text)
+ (random@map /.identifier ..random-name)
+ (random@map /.tag ..random-name)
+ (random@map /.form (..random-sequence random))
+ (random@map /.tuple (..random-sequence random))
+ (random@map /.record (..random-record random))
+ ))))
+
+(def: (read source-code)
+ (-> Text (Try Code))
+ (let [parse (syntax.parse ""
+ syntax.no-aliases
+ (text.size source-code))
+ start (: Source
+ [.dummy-cursor 0 source-code])]
+ (case (parse start)
+ (#.Left [end error])
+ (#try.Failure error)
+
+ (#.Right [end lux-code])
+ (#try.Success lux-code))))
+
+(def: (replace-simulation [original substitute])
+ (-> [Code Code] (Random [Code Code]))
+ (random.rec
+ (function (_ replace-simulation)
+ (let [for-sequence (: (-> (-> (List Code) Code) (Random [Code Code]))
+ (function (_ to-code)
+ (do {@ random.monad}
+ [parts (..random-sequence replace-simulation)]
+ (wrap [(to-code (list@map product.left parts))
+ (to-code (list@map product.right parts))]))))]
+ ($_ random.either
+ (random@wrap [original substitute])
+ (do {@ random.monad}
+ [sample (random.filter (|>> (:: /.equivalence = original) not)
+ ($_ random.either
+ (random@map /.bit random.bit)
+ (random@map /.nat random.nat)
+ (random@map /.int random.int)
+ (random@map /.rev random.rev)
+ (random@map /.frac random.safe-frac)
+ (random@map /.text ..random-text)
+ (random@map /.identifier ..random-name)
+ (random@map /.tag ..random-name)))]
+ (wrap [sample sample]))
+ (for-sequence /.form)
+ (for-sequence /.tuple)
+ (do {@ random.monad}
+ [parts (..random-sequence replace-simulation)]
+ (wrap [(/.record (let [parts' (list@map product.left parts)]
+ (list.zip2 parts' parts')))
+ (/.record (let [parts' (list@map product.right parts)]
+ (list.zip2 parts' parts')))]))
+ )))))
+
(def: #export test
Test
- (<| (_.context (%.name (name-of /._)))
- (do {@ r.monad}
- [bit r.bit
- nat r.nat
- int r.int
- rev r.rev
- above (:: @ map (i.% +100) r.int)
- below (:: @ map (i.% +100) r.int)
- #let [frac (|> below
- (i./ +100)
- i.frac
- (f.+ (i.frac above))
- (f.* -1.0))]
- text (r.ascii 10)
- short (r.ascii/alpha 10)
- module (r.ascii/alpha 10)
- #let [name [module short]]]
- (`` ($_ _.and
- (~~ (template [<desc> <code> <text>]
- [(let [code <code>]
- (_.test (format "Can produce " <desc> " code node.")
- (and (text@= <text> (/.to-text code))
- (:: /.equivalence = code code))))]
-
- ["bit" (/.bit bit) (%.bit bit)]
- ["nat" (/.nat nat) (%.nat nat)]
- ["int" (/.int int) (%.int int)]
- ["rev" (/.rev rev) (%.rev rev)]
- ["frac" (/.frac frac) (%.frac frac)]
- ["text" (/.text text) (%.text text)]
- ["local-ltag" (/.local-tag short) (format "#" short)]
- ["lag" (/.tag [module short]) (format "#" (%.name name))]
- ["local-identifier" (/.local-identifier short) short]
- ["identifier" (/.identifier [module short]) (%.name name)]
- ["form" (/.form (list (/.bit bit) (/.int int))) (format "(" (%.bit bit) " " (%.int int) ")")]
- ["tuple" (/.tuple (list (/.bit bit) (/.int int))) (format "[" (%.bit bit) " " (%.int int) "]")]
- ["record" (/.record (list [(/.bit bit) (/.int int)])) (format "{" (%.bit bit) " " (%.int int) "}")]
- )))))))
+ (<| (_.covering /._)
+ ($_ _.and
+ (_.with-cover [/.equivalence]
+ ($equivalence.spec /.equivalence ..random))
+ (_.with-cover [/.to-text]
+ (`` ($_ _.and
+ (~~ (template [<coverage> <random> <tag>]
+ [(do {@ random.monad}
+ [value <random>]
+ (_.cover [<coverage>]
+ (and (case (..read (/.to-text (<coverage> value)))
+ (#try.Success lux-code)
+ (:: /.equivalence =
+ lux-code
+ (<coverage> value))
+
+ (#try.Failure error)
+ false)
+ (:: /.equivalence =
+ [.dummy-cursor (<tag> value)]
+ (<coverage> value)))))]
+
+ [/.bit random.bit #.Bit]
+ [/.nat random.nat #.Nat]
+ [/.int random.int #.Int]
+ [/.rev random.rev #.Rev]
+ [/.frac random.safe-frac #.Frac]
+ [/.text ..random-text #.Text]
+ [/.tag ..random-name #.Tag]
+ [/.identifier ..random-name #.Identifier]
+ [/.form (..random-sequence ..random) #.Form]
+ [/.tuple (..random-sequence ..random) #.Tuple]
+ [/.record (..random-record ..random) #.Record]
+ ))
+ (~~ (template [<coverage> <random> <tag>]
+ [(do {@ random.monad}
+ [value <random>]
+ (_.cover [<coverage>]
+ (and (case (..read (/.to-text (<coverage> value)))
+ (#try.Success lux-code)
+ (:: /.equivalence =
+ lux-code
+ (<coverage> value))
+
+ (#try.Failure error)
+ false)
+ (:: /.equivalence =
+ [.dummy-cursor (<tag> ["" value])]
+ (<coverage> value)))
+ ))]
+
+ [/.local-tag ..random-text #.Tag]
+ [/.local-identifier ..random-text #.Identifier]
+ )))))
+ (do {@ random.monad}
+ [[original substitute] (random.and ..random ..random)
+ [sample expected] (..replace-simulation [original substitute])]
+ (_.cover [/.replace]
+ (:: /.equivalence =
+ expected
+ (/.replace original substitute sample))))
+ )))
diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux
index 437621fb4..4a5672382 100644
--- a/stdlib/source/test/lux/target/jvm.lux
+++ b/stdlib/source/test/lux/target/jvm.lux
@@ -319,8 +319,8 @@
@.jvm
("jvm object cast"
- (<new-extension> ("jvm object cast" subject)
- ("jvm object cast" parameter)))}))))]
+ (<new-extension> ("jvm object cast" parameter)
+ ("jvm object cast" subject)))}))))]
[int/2 java/lang/Integer]
[long/2 java/lang/Long]
@@ -328,7 +328,7 @@
[double/2 java/lang/Double]
)
-(template: (long+int/2 <old-extension> <new-extension>)
+(template: (int+long/2 <old-extension> <new-extension>)
(: (-> java/lang/Integer java/lang/Long java/lang/Long)
(function (_ parameter subject)
(for {@.old
@@ -336,8 +336,8 @@
@.jvm
("jvm object cast"
- (<new-extension> ("jvm object cast" subject)
- ("jvm object cast" parameter)))}))))
+ (<new-extension> ("jvm object cast" parameter)
+ ("jvm object cast" subject)))}))))
(def: int
Test
@@ -487,9 +487,9 @@
(_.lift "LAND" (binary (long/2 "jvm land" "jvm long and") /.land))
(_.lift "LOR" (binary (long/2 "jvm lor" "jvm long or") /.lor))
(_.lift "LXOR" (binary (long/2 "jvm lxor" "jvm long xor") /.lxor))
- (_.lift "LSHL" (shift (long+int/2 "jvm lshl" "jvm long shl") /.lshl))
- (_.lift "LSHR" (shift (long+int/2 "jvm lshr" "jvm long shr") /.lshr))
- (_.lift "LUSHR" (shift (long+int/2 "jvm lushr" "jvm long ushr") /.lushr)))
+ (_.lift "LSHL" (shift (int+long/2 "jvm lshl" "jvm long shl") /.lshl))
+ (_.lift "LSHR" (shift (int+long/2 "jvm lshr" "jvm long shr") /.lshr))
+ (_.lift "LUSHR" (shift (int+long/2 "jvm lushr" "jvm long ushr") /.lushr)))
comparison (_.lift "LCMP"
(do random.monad
[reference ..$Long::random
@@ -600,19 +600,16 @@
_ instruction
_ /.i2l]
..$Long::wrap)))))
+ comparison-standard (: (-> java/lang/Float java/lang/Float Bit)
+ (function (_ reference subject)
+ (for {@.old
+ ("jvm fgt" subject reference)
+
+ @.jvm
+ ("jvm float <" ("jvm object cast" subject) ("jvm object cast" reference))})))
comparison ($_ _.and
- (_.lift "FCMPL" (comparison /.fcmpl (function (_ reference subject)
- (for {@.old
- ("jvm fgt" subject reference)
-
- @.jvm
- ("jvm float <" ("jvm object cast" reference) ("jvm object cast" subject))}))))
- (_.lift "FCMPG" (comparison /.fcmpg (function (_ reference subject)
- (for {@.old
- ("jvm fgt" subject reference)
-
- @.jvm
- ("jvm float <" ("jvm object cast" subject) ("jvm object cast" reference))})))))]
+ (_.lift "FCMPL" (comparison /.fcmpl comparison-standard))
+ (_.lift "FCMPG" (comparison /.fcmpg comparison-standard)))]
($_ _.and
(<| (_.context "literal")
literal)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 14:37:09 +0000