diff --git a/vector/tests-inspect/Inspect.hs b/vector/tests-inspect/Inspect.hs deleted file mode 100644 index 32cd8cfa..00000000 --- a/vector/tests-inspect/Inspect.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fplugin=Test.Tasty.Inspection.Plugin #-} -{-# OPTIONS_GHC -dsuppress-all #-} -{-# OPTIONS_GHC -dno-suppress-type-signatures #-} --- | Most basic inspection tests -module Inspect where - -import Test.Tasty -import Test.Tasty.Inspection -import qualified Data.Vector as V - -simple_fusion :: Int -> Int -simple_fusion n = V.sum $ V.generate n id - - -tests :: TestTree -tests = testGroup "inspection" - [ $(inspectObligations [(`hasNoType` ''V.Vector), hasNoTypeClasses] 'simple_fusion) - ] diff --git a/vector/tests-inspect/Inspect/Alloc.hs b/vector/tests-inspect/Inspect/Alloc.hs index be399e5f..5627874b 100644 --- a/vector/tests-inspect/Inspect/Alloc.hs +++ b/vector/tests-inspect/Inspect/Alloc.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {- | @@ -7,20 +8,36 @@ Here we test that GHC is able to optimize well construction of vector using monadic\/applicative actions. Well is understood as able to generate code which does not allocate except for buffer and some constant overhead. + +This is test for GHC optimizer as well and older version fail this +test. Thus we have to disable them. However we expect (or rather +hope) that no regressions will appear in future versions. -} module Inspect.Alloc where import Control.Monad.ST import Data.Int +import Data.Word +import Data.Char -- import Data.Monoid import Data.Functor.Identity +import Foreign.Storable (sizeOf) import Test.Tasty import Test.Tasty.HUnit import System.Mem import Test.Alloc +import Test.Ignore import qualified Data.Vector.Unboxed as VU +import Inspect.Fusion + +minGHC :: Int -> TestTree -> TestTree +minGHC n test + | ghcVersion >= n = test + | otherwise = ignoreTest test + where + ghcVersion = __GLASGOW_HASKELL__ :: Int tests :: TestTree tests = testGroup "allocations" @@ -28,23 +45,12 @@ tests = testGroup "allocations" [ testCase "IO" $ checkAllocations (linear 8) $ whnfIO (VU.traverse (\_ -> getAllocationCounter) vector) - -#if MIN_VERSION_base(4,17,0) - -- GHC<9.4 doesn't optimize well. - , testCase "ST" + , minGHC 904 $ testCase "ST" $ checkAllocations (linear 8) $ (\v -> runST $ VU.traverse (pureST . fromIntegral) v) `whnf` vector -#endif - -#if MIN_VERSION_base(4,15,0) - -- GHC<9.0 doesn't optimize this well. And there's no appetite - -- for finding out why. Thus it's disabled for them. We'll still - -- catch regression going forward. - , testCase "Identity" + , minGHC 900 $ testCase "Identity" $ checkAllocations (linear 8) $ VU.traverse (\n -> Identity (10*n)) `whnf` vector -#endif - -- NOTE: Naive traversal is lazy and allocated 2 words per element -- -- , testCase "Const Sum" @@ -55,20 +61,106 @@ tests = testGroup "allocations" [ testCase "IO" $ checkAllocations (linear 8) $ whnfIO (VU.replicateM size getAllocationCounter) - -#if MIN_VERSION_base(4,17,0) - -- GHC<9.4 doesn't optimize well. - , testCase "ST" + , minGHC 904 $ testCase "ST" $ checkAllocations (linear 8) $ (\sz -> runST $ VU.generateM sz pureST) `whnf` size -#endif - + -- NOTE: No rewrite rule for Identity + -- -- , testCase "Identity" -- $ checkAllocations (linear 8) -- $ (\sz -> VU.generateM sz (\n -> Identity (fromIntegral n :: Int64))) `whnf` size ] + , testGroup "Fusion" + [ testGroup "transformers" + [ allocWHNF "test_map" test_map vectorI + , allocWHNF "test_imap" test_imap vectorI + , allocWHNF "test_mapMaybe" test_mapMaybe vectorI + , allocWHNF "test_cons" test_cons vectorI + , allocWHNF "test_snoc" test_snoc vectorI + -- FIXME: GHC does not fuse intermediate vectors in concatMap + -- + -- , allocWHNF "test_concatMap_singleton" test_concatMap_singleton vectorI + -- , allocWHNF "test_concatMap_replicate" test_concatMap_replicate vectorI + , allocWHNF "test_appendL" (test_appendL vectorI) vectorI + , allocWHNF "test_appendR" (test_appendR vectorI) vectorI + , allocWHNF "test_indexed" test_indexed vectorI + ] + , testGroup "producers" + [ allocWHNF "test_replicate" test_replicate size + , allocWHNF "test_generate" test_generate size + , allocWHNF "test_iterateN" test_iterateN size + , allocWHNF "test_unfoldr" test_unfoldr size + , allocWHNF "test_unfoldrN" test_unfoldrN size + , allocWHNF "test_enumFromN" test_enumFromN size + , allocWHNF "test_enumFromStepN" test_enumFromStepN size + + , allocWHNF "test_enumFromTo[Int]" (test_enumFromTo @Int fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Int64]" (test_enumFromTo @Int64 fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Int32]" (test_enumFromTo @Int32 fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Int16]" (test_enumFromTo @Int16 fromIntegral 0) maxBound + , allocWHNF "test_enumFromTo[Word]" (test_enumFromTo @Word fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Word64]" (test_enumFromTo @Word64 fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Word32]" (test_enumFromTo @Word32 fromIntegral 0) 100000 + , allocWHNF "test_enumFromTo[Word16]" (test_enumFromTo @Word16 fromIntegral 0) maxBound + , allocWHNF "test_enumFromTo[Float]" (test_enumFromTo @Float round 0) 100000 + , allocWHNF "test_enumFromTo[Double]" (test_enumFromTo @Double round 0) 100000 + , allocWHNF "test_enumFromTo[Char]" (test_enumFromTo @Char ord (chr 32)) (chr 8000) + -- FIXME: We don't have specializations for enumFromThenTo + -- + -- , allocWHNF "test_enumFromThenTo" test_enumFromThenTo size + ] + , testGroup "consumers" + [ allocWHNF "test_bang" test_bang vectorI + , allocWHNF "test_safeBang" test_safeBang vectorI + , allocWHNF "test_head" test_head vectorI + , allocWHNF "test_last" test_last vectorI + , allocWHNF "test_unsafeHead" test_unsafeHead vectorI + , allocWHNF "test_unsafeLast" test_unsafeLast vectorI + , allocWHNF "test_indexM" test_indexM vectorI + , allocWHNF "test_headM" test_headM vectorI + , allocWHNF "test_lastM" test_lastM vectorI + , allocWHNF "test_unsafeHeadM" test_unsafeHeadM vectorI + , allocWHNF "test_unsafeLastM" test_unsafeLastM vectorI + ] + , testGroup "update" + [ allocVecWHNF "test_upd" (test_upd listUpd) vectorI + , allocVecWHNF "test_update_1" (test_update_1 vectorIdx) vectorI + , allocVecWHNF "test_update_2" (test_update_2 vectorI) vectorI + , allocVecWHNF "test_update__1" (test_update__1 vectorI vectorI) vectorI + , minGHC 904 $ allocVecWHNF "test_update__2" (test_update__2 vectorI vectorI) vectorI + , allocVecWHNF "test_update__3" (test_update__3 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeUpdate_1" (test_unsafeUpdate_1 vectorIdx) vectorI + , allocVecWHNF "test_unsafeUpdate_2" (test_unsafeUpdate_2 vectorI) vectorI + , allocVecWHNF "test_unsafeUpdate__1" (test_unsafeUpdate__1 vectorI vectorI) vectorI + , minGHC 904 $ allocVecWHNF "test_unsafeUpdate__2" (test_unsafeUpdate__2 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeUpdate__3" (test_unsafeUpdate__3 vectorI vectorI) vectorI + , allocVecWHNF "test_accumulate_1" (test_accumulate_1 vectorIdx) vectorI + , allocVecWHNF "test_accumulate_2" (test_accumulate_2 vectorI) vectorI + , allocVecWHNF "test_accumulate__1" (test_accumulate__1 vectorI vectorI) vectorI + , minGHC 904 $ allocVecWHNF "test_accumulate__2" (test_accumulate__2 vectorI vectorI) vectorI + , allocVecWHNF "test_accumulate__3" (test_accumulate__3 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeAccumulate_1" (test_unsafeAccumulate_1 vectorIdx) vectorI + , minGHC 904 $ allocVecWHNF "test_unsafeAccumulate_2" (test_unsafeAccumulate_2 vectorI) vectorI + , allocVecWHNF "test_unsafeAccumulate__1" (test_unsafeAccumulate__1 vectorI vectorI) vectorI + , minGHC 904 $ allocVecWHNF "test_unsafeAccumulate__2" (test_unsafeAccumulate__2 vectorI vectorI) vectorI + , allocVecWHNF "test_unsafeAccumulate__3" (test_unsafeAccumulate__3 vectorI vectorI) vectorI + ] + , testGroup "other" + [ allocWHNF "test_concat" test_concat listVectorI + ] + ] ] +allocWHNF :: String -> (a -> b) -> a -> TestTree +{-# INLINE allocWHNF #-} +allocWHNF name f a = testCase name $ checkAllocations constant (f `whnf` a) + +allocVecWHNF :: String -> (a -> b) -> a -> TestTree +{-# INLINE allocVecWHNF #-} +allocVecWHNF name f a + = testCase name + $ checkAllocations (linear (sizeOf (undefined::Int))) (f `whnf` a) + pureST :: Int -> ST s Int64 {-# NOINLINE pureST #-} @@ -87,6 +179,23 @@ vector :: VU.Vector Int64 {-# NOINLINE vector #-} vector = VU.generate size fromIntegral +vectorI :: VU.Vector Int +{-# NOINLINE vectorI #-} +vectorI = VU.generate size fromIntegral + +vectorIdx :: VU.Vector (Int,Int) +{-# NOINLINE vectorIdx #-} +vectorIdx = VU.map (\i -> (i`div`3, i)) vectorI + +listVectorI :: [VU.Vector Int] +{-# NOINLINE listVectorI #-} +listVectorI = replicate 8 vectorI + +listUpd :: [(Int,Int)] +{-# NOINLINE listUpd #-} +listUpd = [(0,0), (1000,0), (100,0)] + + -- | N bytes per element + constant overhead. We also check that bound -- is tight. linear :: Int -> Range diff --git a/vector/tests-inspect/Inspect/Fusion.hs b/vector/tests-inspect/Inspect/Fusion.hs new file mode 100644 index 00000000..2dd32428 --- /dev/null +++ b/vector/tests-inspect/Inspect/Fusion.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -dsuppress-all #-} +{-# OPTIONS_GHC -dno-suppress-type-signatures #-} +-- | +module Inspect.Fusion where + +import Test.Tasty +-- import Test.Tasty.Inspection +import qualified Data.Vector.Unboxed as VU +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Generic as VG +import Data.Vector.Fusion.Util (Box) + +import Test.InspectExtra + +-- NOTE: [Fusion tests] +-- ~~~~~~~~~~~~~~~~~~~~ +-- +-- In this module we define functions to be tested. All test functions +-- are constructed in the that there should be no vector allocations +-- if fusion happens. There are two tests for each function: +-- +-- 1. Inspection tests which tests that GHC successfully eliminate +-- stream data types. They also allow to inspect core of offending +-- function easily using coreOf property. +-- +-- 2. Allocation tests which measure memory allocation during +-- function execution. It's difficult to check that fusion happens +-- by inspecting core so we fall back to checking function +-- behavior. This methods also requires that GHC is able to +-- compile function to nonallocating loops, but that's desirable +-- property as well. + +goodConsumer + :: (VG.Vector v a, Num a) + => (v a -> b) -> (v a -> b) +{-# INLINE goodConsumer #-} +goodConsumer f = f . VG.map (+1) + +goodTransformer + :: (VG.Vector v a, VG.Vector v b, Num a, Num b) + => (v a -> v b) -> (v a -> b) +{-# INLINE goodTransformer #-} +goodTransformer f = VG.sum . f . VG.map (+1) + +goodProducer + :: (VG.Vector v a, Num a) + => (b -> v a) -> (b -> a) +{-# INLINE goodProducer #-} +goodProducer f = VG.sum . f + + + +---------------------------------------------------------------- +-- Functions transforming vectors +---------------------------------------------------------------- + +test_map :: Vector Int -> Int +test_map = goodTransformer (VU.map (*2)) + +test_imap :: Vector Int -> Int +test_imap = goodTransformer (VU.imap (+)) + +test_mapMaybe :: Vector Int -> Int +test_mapMaybe = goodTransformer (VU.mapMaybe (\x -> if odd x then Just x else Nothing)) + +test_cons :: Vector Int -> Int +test_cons = goodTransformer (VU.cons 123) + +test_snoc :: Vector Int -> Int +test_snoc = goodTransformer (`VU.snoc` 123) + +test_concatMap_singleton :: Vector Int -> Int +test_concatMap_singleton = goodTransformer (VU.concatMap VU.singleton) + +test_concatMap_replicate :: Vector Int -> Int +test_concatMap_replicate = goodTransformer (VU.concatMap (VU.replicate 10)) + +test_appendR, test_appendL :: Vector Int -> Vector Int -> Int +test_appendR v = goodTransformer (v VU.++) +test_appendL v = goodTransformer (VU.++ v) + +test_indexed :: Vector Int -> Int +test_indexed = goodTransformer (VU.map (\(i,j) -> i+j) . VU.indexed) + + +---------------------------------------------------------------- +-- Update/accumulate +---------------------------------------------------------------- + +test_upd :: [(Int,Int)] -> Vector Int -> Int +test_upd xs = goodTransformer (VU.// xs) + +test_update_1 :: Vector (Int,Int) -> Vector Int -> Int +test_update_1 xs + = goodTransformer (\vec -> VU.update vec xs) + +test_update_2 :: Vector Int -> Vector Int -> Int +test_update_2 vec + = goodTransformer (VU.update vec . VU.map (\i -> (i`div`3, i))) + +test_update__1, test_update__2, test_update__3 + :: Vector Int -> Vector Int -> Vector Int -> Int +-- NOTE: We need to ensure that index won't get out of range +test_update__1 y z = goodTransformer (\x -> VU.update_ x y z) +test_update__2 x z = goodTransformer (\y -> VU.update_ x (VU.map (`div` 3) y) z) +test_update__3 x y = goodTransformer (\z -> VU.update_ x y z) + + +test_unsafeUpdate_1 :: Vector (Int,Int) -> Vector Int -> Int +test_unsafeUpdate_1 xs + = goodTransformer (\vec -> VU.unsafeUpdate vec xs) + +test_unsafeUpdate_2 :: Vector Int -> Vector Int -> Int +test_unsafeUpdate_2 vec + = goodTransformer (VU.unsafeUpdate vec . VU.map (\i -> (i`div`3, i))) + +test_unsafeUpdate__1, test_unsafeUpdate__2, test_unsafeUpdate__3 + :: Vector Int -> Vector Int -> Vector Int -> Int +-- NOTE: We need to ensure that index won't get out of range +test_unsafeUpdate__1 y z = goodTransformer (\x -> VU.unsafeUpdate_ x y z) +test_unsafeUpdate__2 x z = goodTransformer (\y -> VU.unsafeUpdate_ x (VU.map (`div` 3) y) z) +test_unsafeUpdate__3 x y = goodTransformer (\z -> VU.unsafeUpdate_ x y z) + + +test_accumulate_1 :: Vector (Int,Int) -> Vector Int -> Int +test_accumulate_1 xs + = goodTransformer (\vec -> VU.accumulate (+) vec xs) + +test_accumulate_2 :: Vector Int -> Vector Int -> Int +test_accumulate_2 vec + = goodTransformer (VU.accumulate (+) vec . VU.map (\i -> (i`div`3, i))) + +test_accumulate__1, test_accumulate__2, test_accumulate__3 + :: Vector Int -> Vector Int -> Vector Int -> Int +-- NOTE: We need to ensure that index won't get out of range +test_accumulate__1 y z = goodTransformer (\x -> VU.accumulate_ (+) x y z) +test_accumulate__2 x z = goodTransformer (\y -> VU.accumulate_ (+) x (VU.map (`div` 3) y) z) +test_accumulate__3 x y = goodTransformer (\z -> VU.accumulate_ (+) x y z) + + +test_unsafeAccumulate_1 :: Vector (Int,Int) -> Vector Int -> Int +test_unsafeAccumulate_1 xs + = goodTransformer (\vec -> VU.unsafeAccumulate (+) vec xs) + +test_unsafeAccumulate_2 :: Vector Int -> Vector Int -> Int +test_unsafeAccumulate_2 vec + = goodTransformer (VU.unsafeAccumulate (+) vec . VU.map (\i -> (i`div`3, i))) + +test_unsafeAccumulate__1, test_unsafeAccumulate__2, test_unsafeAccumulate__3 + :: Vector Int -> Vector Int -> Vector Int -> Int +-- NOTE: We need to ensure that index won't get out of range +test_unsafeAccumulate__1 y z = goodTransformer (\x -> VU.unsafeAccumulate_ (+) x y z) +test_unsafeAccumulate__2 x z = goodTransformer (\y -> VU.unsafeAccumulate_ (+) x (VU.map (`div` 3) y) z) +test_unsafeAccumulate__3 x y = goodTransformer (\z -> VU.unsafeAccumulate_ (+) x y z) + + +---------------------------------------------------------------- +-- Function creating vectors +---------------------------------------------------------------- + +test_replicate :: Int -> Double +test_replicate = goodProducer (\n -> VU.replicate n 12.0) + +test_generate :: Int -> Int +test_generate = goodProducer (\n -> VU.generate n id) + +test_iterateN :: Int -> Int +test_iterateN = goodProducer (\n -> VU.iterateN n (+1) 0) + +test_unfoldr :: Int -> Int +test_unfoldr = goodProducer (\n -> VU.unfoldr (\i -> if i > n then Nothing else Just (i,i+1)) 0) + +test_unfoldrN :: Int -> Int +test_unfoldrN = goodProducer (\n -> VU.unfoldrN n (\i -> Just (i,i+1)) 0) + +test_enumFromN, test_enumFromStepN :: Int -> Double +test_enumFromN = goodProducer (\n -> VU.enumFromN 123 n) +test_enumFromStepN = goodProducer (\n -> VU.enumFromStepN 123 2 n) + + +-- NOTE: [enumFromTo] +-- ~~~~~~~~~~~~~~~~~ +-- +-- both enumFromTo and enumFromThenTo are wrapping methods of Enum +-- type class and thus has to create list and allocate. However we +-- have extensive set of rewrite rules which produce specializations +-- for base types. +-- +-- For this reason we need to write test for all specializations + +test_enumFromTo :: (Enum a, VU.Unbox a) => (a -> Int) -> a -> a -> Int +{-# INLINE test_enumFromTo #-} +test_enumFromTo fun a + = goodProducer (VU.map fun . VU.enumFromTo a) + +test_enumFromThenTo :: (Enum a, VU.Unbox a) => (a -> Int) -> a -> a -> a -> Int +test_enumFromThenTo fun a b + = goodProducer (VU.map fun . VU.enumFromThenTo a b) + + + +---------------------------------------------------------------- +-- Function consuming vectors +---------------------------------------------------------------- + +test_bang,test_unsafeIndex :: Vector Int -> Int +test_bang = goodConsumer (VU.! 42000) +test_unsafeIndex = goodConsumer (`VU.unsafeIndex` 42) + +test_safeBang :: Vector Int -> Maybe Int +test_safeBang = goodConsumer (VU.!? 42000) + +test_head, test_last, test_unsafeHead, test_unsafeLast :: Vector Int -> Int +test_head = goodConsumer VU.head +test_last = goodConsumer VU.last +test_unsafeHead = goodConsumer VU.unsafeHead +test_unsafeLast = goodConsumer VU.unsafeLast + +test_headM, test_lastM, test_unsafeHeadM, test_unsafeLastM, test_indexM :: Vector Int -> Box Int +test_indexM = goodConsumer (`VU.indexM` 43) +test_headM = goodConsumer VU.headM +test_lastM = goodConsumer VU.lastM +test_unsafeHeadM = goodConsumer VU.unsafeHeadM +test_unsafeLastM = goodConsumer VU.unsafeLastM + +---------------------------------------------------------------- +-- Functions involving lists +---------------------------------------------------------------- + +test_concat :: [Vector Int] -> Int +test_concat = VU.sum . VU.map (+1) . VU.concat + + + +---------------------------------------------------------------- +-- Inspection tests +-- +-- They have to be defined in this module +---------------------------------------------------------------- + +tests :: TestTree +tests = testGroup "Fusion" + [ testGroup "transformers" + [ $(inspectFusion 'test_map) + , $(inspectFusion 'test_imap) + , $(inspectFusion 'test_mapMaybe) + , $(inspectFusion 'test_cons) + , $(inspectFusion 'test_snoc) + , $(inspectFusion 'test_concatMap_singleton) + , $(inspectFusion 'test_concatMap_replicate) + , $(inspectFusion 'test_appendL) + , $(inspectFusion 'test_appendR) + , $(inspectFusion 'test_indexed) + ] + , testGroup "updates" + [ $(inspectFusion 'test_upd) + , $(inspectFusion 'test_update_1) + , $(inspectFusion 'test_update_2) + , $(inspectFusion 'test_update__1) + , $(inspectFusion 'test_update__2) + , $(inspectFusion 'test_update__3) + , $(inspectFusion 'test_unsafeUpdate_1) + , $(inspectFusion 'test_unsafeUpdate_2) + , $(inspectFusion 'test_unsafeUpdate__1) + , $(inspectFusion 'test_unsafeUpdate__2) + , $(inspectFusion 'test_unsafeUpdate__3) + , $(inspectFusion 'test_accumulate_1) + , $(inspectFusion 'test_accumulate_2) + , $(inspectFusion 'test_accumulate__1) + , $(inspectFusion 'test_accumulate__2) + , $(inspectFusion 'test_accumulate__3) + , $(inspectFusion 'test_unsafeAccumulate_1) + , $(inspectFusion 'test_unsafeAccumulate_2) + , $(inspectFusion 'test_unsafeAccumulate__1) + , $(inspectFusion 'test_unsafeAccumulate__2) + , $(inspectFusion 'test_unsafeAccumulate__3) + ] + , testGroup "producers" + [ $(inspectFusion 'test_replicate) + , $(inspectFusion 'test_generate) + , $(inspectFusion 'test_iterateN) + , $(inspectFusion 'test_unfoldr) + , $(inspectFusion 'test_unfoldrN) + , $(inspectFusion 'test_enumFromN) + , $(inspectFusion 'test_enumFromStepN) + , $(inspectClassyFusion 'test_enumFromTo) + , $(inspectClassyFusion 'test_enumFromThenTo) + ] + , testGroup "consumers" + [ $(inspectFusion 'test_bang) + , $(inspectFusion 'test_safeBang) + , $(inspectFusion 'test_head) + , $(inspectFusion 'test_last) + , $(inspectFusion 'test_unsafeHead) + , $(inspectFusion 'test_unsafeLast) + , $(inspectFusion 'test_indexM) + , $(inspectFusion 'test_headM) + , $(inspectFusion 'test_lastM) + , $(inspectFusion 'test_unsafeHeadM) + , $(inspectFusion 'test_unsafeLastM) + ] + , testGroup "other" + [ $(inspectFusion 'test_concat) + ] + ] diff --git a/vector/tests-inspect/Test/Ignore.hs b/vector/tests-inspect/Test/Ignore.hs new file mode 100644 index 00000000..936711f5 --- /dev/null +++ b/vector/tests-inspect/Test/Ignore.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +module Test.Ignore + ( modifyTests + , ignoreTest + ) where + +import Data.Coerce +import Test.Tasty +import Test.Tasty.Runners +import Test.Tasty.Providers + + +data WithTest where + WithTest :: IsTest t => t -> WithTest + +modifyTests + :: (forall a. (IsTest a) => a -> WithTest) + -> TestTree -> TestTree +modifyTests fun = go where + go = \case + SingleTest nm t -> case fun t of + WithTest t' -> SingleTest nm t' + TestGroup nm ts -> TestGroup nm (go <$> ts) + PlusTestOptions plus tree -> PlusTestOptions plus (go tree) + WithResource spec f -> WithResource spec (go . f) + AskOptions f -> AskOptions (go . f) + After d p t -> After d p (go t) + + +ignoreTest :: TestTree -> TestTree +ignoreTest = modifyTests (\t -> WithTest $ Ignored t) + +newtype Ignored t = Ignored t + +instance IsTest t => IsTest (Ignored t) where + run ops (Ignored t) f = do + _ <- run ops t f + pure $ (testPassed ""){ resultShortDescription = "IGNORED" } + testOptions = coerce (testOptions @t) diff --git a/vector/tests-inspect/Test/InspectExtra.hs b/vector/tests-inspect/Test/InspectExtra.hs new file mode 100644 index 00000000..ce73e9a1 --- /dev/null +++ b/vector/tests-inspect/Test/InspectExtra.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Helpers for fusion tests +module Test.InspectExtra + ( noStream + , inspectFusion + , inspectClassyFusion + , module Test.Tasty.Inspection + ) where + +import Language.Haskell.TH (Name,Q,Exp) +import Test.Tasty.Inspection + +import qualified Data.Stream.Monadic as S + + +noStream :: Name -> Obligation +noStream = (`doesNotUseAnyOf` ['S.Yield, 'S.Skip, 'S.Done]) + +inspectFusion :: Name -> Q Exp +inspectFusion = inspectObligations [ noStream + , hasNoTypeClasses + ] + +inspectClassyFusion :: Name -> Q Exp +inspectClassyFusion = inspectObligations [ noStream ] diff --git a/vector/tests-inspect/main.hs b/vector/tests-inspect/main.hs index 0a67eb9f..12d554af 100644 --- a/vector/tests-inspect/main.hs +++ b/vector/tests-inspect/main.hs @@ -1,13 +1,13 @@ module Main (main) where -import qualified Inspect import qualified Inspect.Alloc import qualified Inspect.DerivingVia +import qualified Inspect.Fusion import Test.Tasty (defaultMain,testGroup) main :: IO () main = defaultMain $ testGroup "tests" - [ Inspect.tests - , Inspect.DerivingVia.tests + [ Inspect.DerivingVia.tests , Inspect.Alloc.tests + , Inspect.Fusion.tests ] diff --git a/vector/vector.cabal b/vector/vector.cabal index 479b35fe..e32230cc 100644 --- a/vector/vector.cabal +++ b/vector/vector.cabal @@ -247,20 +247,27 @@ test-suite vector-doctest test-suite vector-inspection import: flag-Wall + -- We need to compile with -O2 since we're checking that function on vectors are + -- compiled down to nonallocating loops. GHC is not good at this with only -O1 + Ghc-Options: -O2 type: exitcode-stdio-1.0 hs-source-dirs: tests-inspect main-is: main.hs default-language: Haskell2010 - Other-modules: Inspect - Inspect.Alloc + Other-modules: Inspect.Alloc + Inspect.Fusion Inspect.DerivingVia Inspect.DerivingVia.OtherFoo Test.Alloc + Test.InspectExtra + Test.Ignore build-depends: base -any + , template-haskell , primitive >= 0.6.4.0 && < 0.10 , vector -any - , tasty + , vector-stream -any + , tasty >=1.2 , tasty-hunit , tasty-inspection-testing >= 0.1