Merge pull request #33 from cartazio/master

fix long standing fusion bug in enumFromTo_double and improve baseline testing tooling

Author: dolio

.travis.yml

@@ -22,10 +22,10 @@ before_install:
 
 install:
  - travis_retry cabal update
- - cabal install --only-dependencies
+ - cabal install --enable-tests --only-dependencies
 
 script:
- - cabal configure -v2
+ - cabal configure -v2 --enable-tests
  - cabal build
  - cabal sdist
  - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;

Data/Vector/Fusion/Bundle/Monadic.hs

@@ -943,7 +943,7 @@ enumFromTo_char x y = x `seq` y `seq` fromStream (Stream step xn) (Exact n)
 
 enumFromTo_double :: (Monad m, Ord a, RealFrac a) => a -> a -> Bundle m v a
 {-# INLINE_FUSED enumFromTo_double #-}
-enumFromTo_double n m = n `seq` m `seq` fromStream (Stream step n) (Max (len n m))
+enumFromTo_double n m = n `seq` m `seq` fromStream (Stream step n) (Max (len n lim))
   where
     lim = m + 1/2 -- important to float out
 

tests/Tests/Move.hs

@@ -2,6 +2,7 @@ module Tests.Move (tests) where
 
 import Test.QuickCheck
 import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck.Property (Property(..))
 
 import Utilities ()
 
@@ -14,18 +15,18 @@ import qualified Data.Vector.Storable as S
 import qualified Data.Vector.Unboxed as U
 
 basicMove :: G.Vector v a => v a -> Int -> Int -> Int -> v a
-basicMove v dstOff srcOff len 
+basicMove v dstOff srcOff len
   | len > 0 = G.modify (\ mv -> G.copy (M.slice dstOff len mv) (G.slice srcOff len v)) v
   | otherwise = v
 
 testMove :: (G.Vector v a, Show (v a), Eq (v a)) => v a -> Property
-testMove v = G.length v > 0 ==> (do
+testMove v = G.length v > 0 ==> (MkProperty $ do
   dstOff <- choose (0, G.length v - 1)
   srcOff <- choose (0, G.length v - 1)
   len <- choose (1, G.length v - max dstOff srcOff)
-  let expected = basicMove v dstOff srcOff len
-  let actual = G.modify (\ mv -> M.move (M.slice dstOff len mv) (M.slice srcOff len mv)) v
-  printTestCase ("Move: " ++ show (v, dstOff, srcOff, len)) (expected == actual))
+  expected <- return $ basicMove v dstOff srcOff len
+  actual <- return $  G.modify (\ mv -> M.move (M.slice dstOff len mv) (M.slice srcOff len mv)) v
+  unProperty $ counterexample ("Move: " ++ show (v, dstOff, srcOff, len)) (expected == actual))
 
 tests =
     [testProperty "Data.Vector.Mutable (Move)" (testMove :: V.Vector Int -> Property),

tests/Tests/Vector.hs

@@ -1,7 +1,7 @@
 module Tests.Vector (tests) where
 
 import Boilerplater
-import Utilities
+import Utilities as Util
 
 import qualified Data.Vector.Generic as V
 import qualified Data.Vector
@@ -118,7 +118,7 @@ testPolymorphicFunctions _ = $(testProperties [
         'prop_concat,
 
         -- Restricting memory usage
-        'prop_force, 
+        'prop_force,
 
 
         -- Bulk updates (FIXME)
@@ -213,7 +213,7 @@ testPolymorphicFunctions _ = $(testProperties [
     prop_concat    :: P ([v a] -> v a) = V.concat `eq` concat
     prop_force     :: P (v a -> v a)        = V.force `eq` id
     prop_generate  :: P (Int -> (Int -> a) -> v a)
-              = (\n _ -> n < 1000) ===> V.generate `eq` generate
+              = (\n _ -> n < 1000) ===> V.generate `eq` Util.generate
     prop_iterateN  :: P (Int -> (a -> a) -> a -> v a)
               = (\n _ _ -> n < 1000) ===> V.iterateN `eq` (\n f -> take n . iterate f)
 
@@ -357,7 +357,7 @@ testPolymorphicFunctions _ = $(testProperties [
                  V.scanl1 `eq` scanl1
     prop_scanl1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===>
                  V.scanl1' `eq` scanl1
- 
+
     prop_prescanr :: P ((a -> a -> a) -> a -> v a -> v a)
                 = V.prescanr `eq` prescanr
     prop_prescanr' :: P ((a -> a -> a) -> a -> v a -> v a)
@@ -395,7 +395,7 @@ testPolymorphicFunctions _ = $(testProperties [
     --prop_mapAccumL  = eq3
     --    (V.mapAccumL :: (X -> W -> (X,W)) -> X -> B   -> (X, B))
     --    (  mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W]))
-    -- 
+    --
     --prop_mapAccumR  = eq3
     --    (V.mapAccumR :: (X -> W -> (X,W)) -> X -> B   -> (X, B))
     --    (  mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W]))
@@ -529,7 +529,7 @@ testNestedVectorFunctions _ = $(testProperties [])
   where
     -- Prelude
     --prop_concat       = (V.concat :: [v a] -> v a)                    `eq1` concat
-    
+
     -- Data.List
     --prop_transpose    = V.transpose   `eq1` (transpose   :: [v a] -> [v a])
     --prop_group        = V.group       `eq1` (group       :: v a -> [v a])

vector.cabal

@@ -39,7 +39,6 @@ Build-Type:     Simple
 
 Extra-Source-Files:
       README.md
-      tests/vector-tests.cabal
       tests/LICENSE
       tests/Setup.hs
       tests/Main.hs
@@ -157,3 +156,51 @@ Library
 source-repository head
   type:     git
   location: https://github.com/haskell/vector.git
+
+
+
+test-suite vector-tests-O0
+  Default-Language: Haskell2010
+  type: exitcode-stdio-1.0
+  Main-Is:  Main.hs
+  hs-source-dirs: tests
+  Build-Depends: base >= 4 && < 5, template-haskell, vector,
+                 random,
+                 QuickCheck >=  2.7  && < 2.8 , test-framework, test-framework-quickcheck2,
+                 transformers >= 0.2.0.0
+
+  default-extensions: CPP,
+              ScopedTypeVariables,
+              PatternGuards,
+              MultiParamTypeClasses,
+              FlexibleContexts,
+              Rank2Types,
+              TypeSynonymInstances,
+              TypeFamilies,
+              TemplateHaskell
+
+  Ghc-Options: -O0
+  Ghc-Options: -Wall -fno-warn-orphans -fno-warn-missing-signatures
+
+test-suite vector-tests-O2
+  Default-Language: Haskell2010
+  type: exitcode-stdio-1.0
+  Main-Is:  Main.hs
+  hs-source-dirs: tests
+  Build-Depends: base >= 4 && < 5, template-haskell, vector,
+                 random,
+                 QuickCheck  >= 2.7, test-framework, test-framework-quickcheck2,
+                 transformers >= 0.2.0.0
+
+  default-extensions: CPP,
+              ScopedTypeVariables,
+              PatternGuards,
+              MultiParamTypeClasses,
+              FlexibleContexts,
+              Rank2Types,
+              TypeSynonymInstances,
+              TypeFamilies,
+              TemplateHaskell
+
+  Ghc-Options: -O2
+  Ghc-Options: -Wall -fno-warn-orphans -fno-warn-missing-signatures