Also bench and improve chooseBackwards

Author: MaximilianAlgehed

bench/Constrained/Bench.hs

@@ -13,6 +13,7 @@ import Constrained.API
 import Constrained.Generation
 import Constrained.Examples.Set
 import Constrained.Examples.Map
+import Constrained.Examples.Basic
 
 import Control.DeepSeq
 import Criterion
@@ -37,6 +38,7 @@ benchmarks =
     , benchSpec 10 30 "maybeJustSetSpec" maybeJustSetSpec
     , benchSpec 10 40 "eitherKeys" eitherKeys
     , benchSimplifySpec "eitherKeys" eitherKeys
+    , benchSpec 10 40 "chooseBackwards" chooseBackwards'
     ]
 
 roseTreeMaybe :: Specification (Tree (Maybe (Int, Int)))

src/Constrained/Spec/List.hs

@@ -227,7 +227,8 @@ instance HasSpec a => HasSpec [a] where
       Just szHint -> do
         sz <- genFromSizeSpec (leqSpec szHint)
         listOfUntilLenT (genFromSpecT elemS) (fromIntegral sz) (const True)
-    pureGen $ shuffle (must ++ lst)
+    must' <- pureGen $ shuffle must
+    pureGen $ randomInterleaving must' lst
   genFromTypeSpec (ListSpec msz must szSpec elemS NoFold) = do
     sz0 <- genFromSizeSpec (szSpec <> geqSpec (sizeOf must) <> maybe TrueSpec (leqSpec . max 0) msz)
     let sz = fromIntegral (sz0 - sizeOf must)
@@ -236,7 +237,8 @@ instance HasSpec a => HasSpec [a] where
         (genFromSpecT elemS)
         sz
         ((`conformsToSpec` szSpec) . (+ sizeOf must) . fromIntegral)
-    pureGen $ shuffle (must ++ lst)
+    must' <- pureGen $ shuffle must
+    pureGen $ randomInterleaving must' lst
   genFromTypeSpec (ListSpec msz must szSpec elemS (FoldSpec f foldS)) = do
     let szSpec' = szSpec <> maybe TrueSpec (leqSpec . max 0) msz
     genFromFold must szSpec' elemS f foldS
@@ -266,6 +268,25 @@ instance HasSpec a => HasSpec [a] where
       <> satisfies (sizeOf_ x) size
       <> maybe TruePred (flip genHint x) msz
 
+randomInterleaving :: [a] -> [a] -> Gen [a]
+randomInterleaving xs ys = go xs ys (length ys)
+  where
+    go [] ys _ = pure ys
+    go xs [] _ = pure xs
+    go xs ys l = do
+      i <- choose (0, l)
+      go' i xs ys (l - i)
+
+    go' _ xs [] _ = pure xs
+    go' _ [] ys _ = pure ys
+    go' 0 (x:xs) ys l = (x:) <$> go xs ys l
+    go' i xs (y:ys) l = (y:) <$> go' (i-1) xs ys l
+
+genSplit :: [a] -> Gen ([a], [a])
+genSplit as = do
+  s <- choose (0, length as)
+  return $ splitAt s as
+
 instance HasSpec a => HasGenHint [a] where
   type Hint [a] = Integer
   giveHint szHint = typeSpec $ ListSpec (Just szHint) [] mempty mempty NoFold