From 7358718500e9bf1adc78092bdcf90ee9c2231df7 Mon Sep 17 00:00:00 2001
From: Maximilian Algehed <m.algehed@gmail.com>
Date: Thu, 10 Oct 2024 16:28:26 +0200
Subject: [PATCH] `constrained-generators`: Tests for `(++.)` and
 `singletonList_`

---
 .../src/Constrained/Examples/List.hs          | 38 +++++++++++++++++++
 .../test/Constrained/Test.hs                  | 25 +++++++-----
 2 files changed, 54 insertions(+), 9 deletions(-)

diff --git a/libs/constrained-generators/src/Constrained/Examples/List.hs b/libs/constrained-generators/src/Constrained/Examples/List.hs
index 113a6ea1442..60d5b0c2539 100644
--- a/libs/constrained-generators/src/Constrained/Examples/List.hs
+++ b/libs/constrained-generators/src/Constrained/Examples/List.hs
@@ -129,6 +129,16 @@ singletonSubset :: Specification BaseFn Int
 singletonSubset = constrained $ \ [var| x |] ->
   fromList_ (singletonList_ x) `subset_` fromList_ (lit [1, 2, 3])
 
+appendSuffix :: Specification BaseFn ([Int], [Int])
+appendSuffix = constrained' $
+  \ [var|x|] [var|y|] -> assert $ x ==. y ++. lit [4, 5, 6]
+
+appendForAll :: Specification BaseFn ([Int], [Int])
+appendForAll = constrained' $ \ [var| xs |] [var| ys |] ->
+  [ forAll xs $ \x -> x `elem_` lit [2, 4 .. 10]
+  , assert $ xs ==. ys ++. lit [2, 4, 6]
+  ]
+
 -- Some notable error cases that shouldn't succeed
 
 singletonErrorTooMany :: Specification BaseFn Int
@@ -142,3 +152,31 @@ singletonErrorTooLong = constrained $ \ [var| x |] ->
 appendTooLong :: Specification BaseFn [Int]
 appendTooLong = constrained $ \ [var| xs |] ->
   sizeOf_ (lit [1, 2, 3, 4] ++. xs) <=. 3
+
+-- | Fails because the cant set is over constrained
+overconstrainedAppend :: Specification BaseFn ([Int], [Int])
+overconstrainedAppend = constrained' $
+  \ [var|x|] [var|y|] ->
+    [ dependsOn y x
+    , assert $ x ==. lit [1, 2, 3] ++. y
+    , assert $ y ==. lit [4, 5, 6]
+    , assert $ x /=. lit [1, 2, 3, 4, 5, 6]
+    ]
+
+overconstrainedPrefixes :: Specification BaseFn ([Int], [Int], [Int])
+overconstrainedPrefixes = constrained' $ \ [var| xs |] [var| ys |] [var| zs |] ->
+  [ xs ==. lit [1, 2, 3] ++. ys
+  , xs ==. lit [3, 4, 5] ++. zs
+  ]
+
+overconstrainedSuffixes :: Specification BaseFn ([Int], [Int], [Int])
+overconstrainedSuffixes = constrained' $ \ [var| xs |] [var| ys |] [var| zs |] ->
+  [ xs ==. ys ++. lit [1, 2, 3]
+  , xs ==. zs ++. lit [3, 4, 5]
+  ]
+
+appendForAllBad :: Specification BaseFn ([Int], [Int])
+appendForAllBad = constrained' $ \ [var| xs |] [var| ys |] ->
+  [ forAll xs $ \x -> x `elem_` lit [1 .. 10]
+  , assert $ xs ==. ys ++. lit [2, 4, 11]
+  ]
diff --git a/libs/constrained-generators/test/Constrained/Test.hs b/libs/constrained-generators/test/Constrained/Test.hs
index d396c4c72d0..4413aee2a85 100644
--- a/libs/constrained-generators/test/Constrained/Test.hs
+++ b/libs/constrained-generators/test/Constrained/Test.hs
@@ -152,6 +152,8 @@ tests nightly =
     testSpec "mapRestrictedValuesBool" mapRestrictedValuesBool
     testSpec "mapSetSmall" mapSetSmall
     testSpecNoShrink "powersetPickOne" powersetPickOne
+    testSpecNoShrink "appendSuffix" appendSuffix
+    testSpecNoShrink "appendForAll" appendForAll
     numberyTests
     sizeTests
     numNumSpecTree
@@ -203,15 +205,20 @@ negativeTests =
               (pure "You can't constrain the variable introduced by reify as its already decided")
               $ reify x id
               $ \y -> y ==. 10
-    prop "singletonErrorTooMany" $
-      expectFailure $
-        prop_complete singletonErrorTooMany
-    prop "singletonErrorTooLong" $
-      expectFailure $
-        prop_complete singletonErrorTooLong
-    prop "appendTooLong" $
-      expectFailure $
-        prop_complete appendTooLong
+    testSpecFail "singletonErrorTooMany" singletonErrorTooMany
+    testSpecFail "singletonErrorTooLong" singletonErrorTooLong
+    testSpecFail "appendTooLong" appendTooLong
+    testSpecFail "overconstrainedAppend" overconstrainedAppend
+    testSpecFail "overconstrainedPrefixes" overconstrainedPrefixes
+    testSpecFail "overconstrainedSuffixes" overconstrainedSuffixes
+    testSpecFail "appendForAllBad" appendForAllBad
+
+testSpecFail :: HasSpec fn a => String -> Specification fn a -> Spec
+testSpecFail s spec =
+  prop (s ++ " fails") $
+    expectFailure $
+      withMaxSuccess 1 $
+        prop_complete spec
 
 numberyTests :: Spec
 numberyTests =