Start looking at optimizing num spec

Author: MaximilianAlgehed

bench/Constrained/Bench.hs

@@ -10,6 +10,7 @@
 module Constrained.Bench where
 
 import Constrained.API
+import Constrained.Generation
 import Control.DeepSeq
 import Criterion
 import Data.Map (Map)
@@ -30,8 +31,12 @@ benchmarks =
         (giveHint (Nothing, 30) <> trueSpec :: Specification (Tree Int))
     , benchSpec 10 30 "roseTreeMaybe" roseTreeMaybe
     , benchSpec 10 30 "listSumPair" listSumPair
+    , benchSpec 10 30 "intSpec" (simplifySpec intSpecSimple)
     ]
 
+intSpecSimple :: Specification Int
+intSpecSimple = constrained $ \ x -> 0 <. x
+
 roseTreeMaybe :: Specification (Tree (Maybe (Int, Int)))
 roseTreeMaybe = constrained $ \t ->
   [ forAll' t $ \mp ts ->

src/Constrained/Generation.hs

@@ -132,7 +132,9 @@ genFromSpecT (simplifySpec -> spec) = case spec of
       $
       -- TODO: we could consider giving `cant` as an argument to `genFromTypeSpec` if this
       -- starts giving us trouble.
-      genFromTypeSpec s `suchThatT` (`notElem` cant)
+      case cant of
+        [] -> genFromTypeSpec s
+        _  -> genFromTypeSpec s `suchThatT` (`notElem` cant)
   ErrorSpec e -> genErrorNE e
 
 -- | A version of `genFromSpecT` that simply errors if the generator fails

src/Constrained/NumOrd.hs

@@ -313,7 +313,8 @@ genFromNumSpec ::
   GenT m n
 genFromNumSpec (NumSpecInterval ml mu) = do
   n <- sizeT
-  pureGen . choose =<< constrainInterval (ml <|> lowerBound) (mu <|> upperBound) (fromIntegral n)
+  interval <- constrainInterval (ml <|> lowerBound) (mu <|> upperBound) (fromIntegral n)
+  pureGen $ choose interval
 
 -- TODO: fixme
 
@@ -326,6 +327,7 @@ shrinkWithNumSpec _ = shrink
 fixupWithNumSpec :: Arbitrary n => NumSpec n -> n -> Maybe n
 fixupWithNumSpec _ = listToMaybe . shrink
 
+{-# SCC constrainInterval #-}
 constrainInterval ::
   (MonadGenError m, Ord a, Num a, Show a) => Maybe a -> Maybe a -> Integer -> m (a, a)
 constrainInterval ml mu r =
@@ -336,21 +338,20 @@ constrainInterval ml mu r =
       | otherwise -> pure (l, l + 2 * r')
     (Nothing, Just u)
       | u > 0 -> pure (negate r', min u r')
-      | otherwise -> pure (u - r' - r', u)
+      | otherwise -> pure (u - 2 * r', u)
     (Just l, Just u)
       | l > u -> genError ("bad interval: " ++ show l ++ " " ++ show u)
       | u < 0 -> pure (safeSub l (safeSub l u r') r', u)
-      | l >= 0 -> pure (l, safeAdd u (safeAdd u l r') r')
+      | l >= 0 -> pure (l, safeAdd u l r')
       -- TODO: this is a bit suspect if the bounds are lopsided
       | otherwise -> pure (max l (-r'), min u r')
   where
     r' = abs $ fromInteger r
     safeSub l a b
       | a - b > a = l
       | otherwise = max l (a - b)
-    safeAdd u a b
-      | a + b < a = u
-      | otherwise = min u (a + b)
+    safeAdd u a b =
+      let ab = a + b in if ab < a then u else min u ab
 
 -- | Check that a value is in the spec
 conformsToNumSpec :: Ord n => n -> NumSpec n -> Bool