From 6e43a16a77e2bad6d58ca385e5329717fd73b56a Mon Sep 17 00:00:00 2001 From: Huw Campbell Date: Thu, 14 Dec 2017 16:05:37 +1100 Subject: [PATCH] Bump hedgehog and criterion --- grenade.cabal | 4 ++-- test/Test/Grenade/Layers/Convolution.hs | 7 +++---- test/Test/Grenade/Layers/FullyConnected.hs | 2 +- test/Test/Grenade/Layers/Pooling.hs | 3 +-- test/Test/Grenade/Network.hs | 6 +++--- test/Test/Grenade/Recurrent/Layers/LSTM.hs | 5 ++--- test/Test/Hedgehog/Compat.hs | 24 ++++++++-------------- test/Test/Hedgehog/Hmatrix.hs | 7 ++++--- test/Test/Hedgehog/TypeLits.hs | 11 +++++----- 9 files changed, 30 insertions(+), 39 deletions(-) diff --git a/grenade.cabal b/grenade.cabal index c962f48..88018ca 100644 --- a/grenade.cabal +++ b/grenade.cabal @@ -150,7 +150,7 @@ test-suite test build-depends: base >= 4.8 && < 5 , grenade - , hedgehog >= 0.4 && < 0.5 + , hedgehog >= 0.5 && < 0.6 , hmatrix , mtl , singletons @@ -178,7 +178,7 @@ benchmark bench build-depends: base >= 3 && < 5 , bytestring == 0.10.* - , criterion == 1.1.* + , criterion >= 1.1 && < 1.3 , grenade , hmatrix diff --git a/test/Test/Grenade/Layers/Convolution.hs b/test/Test/Grenade/Layers/Convolution.hs index 5ba810b..9759691 100644 --- a/test/Test/Grenade/Layers/Convolution.hs +++ b/test/Test/Grenade/Layers/Convolution.hs @@ -39,11 +39,10 @@ genConvolution :: ( KnownNat channels , KnownNat strideColumns , KnownNat kernelFlattened , kernelFlattened ~ (kernelRows * kernelColumns * channels) - , Monad m - ) => Gen.Gen m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) + ) => Gen (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) genConvolution = Convolution <$> uniformSample <*> uniformSample -genOpaqueOpaqueConvolution :: Monad m => Gen m OpaqueConvolution +genOpaqueOpaqueConvolution :: Gen OpaqueConvolution genOpaqueOpaqueConvolution = do channels <- genNat filters <- genNat @@ -59,7 +58,7 @@ genOpaqueOpaqueConvolution = do p2 = natDict pkc p3 = natDict pch in case p1 %* p2 %* p3 of - Dict -> OpaqueConvolution <$> (genConvolution :: Monad n => Gen n (Convolution ch fl kr kc sr sc)) + Dict -> OpaqueConvolution <$> (genConvolution :: Gen (Convolution ch fl kr kc sr sc)) prop_conv_net_witness = property $ blindForAll genOpaqueOpaqueConvolution >>= \onet -> diff --git a/test/Test/Grenade/Layers/FullyConnected.hs b/test/Test/Grenade/Layers/FullyConnected.hs index 5c3af83..e9d0553 100644 --- a/test/Test/Grenade/Layers/FullyConnected.hs +++ b/test/Test/Grenade/Layers/FullyConnected.hs @@ -26,7 +26,7 @@ data OpaqueFullyConnected :: * where instance Show OpaqueFullyConnected where show (OpaqueFullyConnected n) = show n -genOpaqueFullyConnected :: Monad m => Gen m OpaqueFullyConnected +genOpaqueFullyConnected :: Gen OpaqueFullyConnected genOpaqueFullyConnected = do input :: Integer <- choose 2 100 output :: Integer <- choose 1 100 diff --git a/test/Test/Grenade/Layers/Pooling.hs b/test/Test/Grenade/Layers/Pooling.hs index 4620cf4..bb8f612 100644 --- a/test/Test/Grenade/Layers/Pooling.hs +++ b/test/Test/Grenade/Layers/Pooling.hs @@ -13,7 +13,6 @@ import GHC.TypeLits import Grenade.Layers.Pooling import Hedgehog -import qualified Hedgehog.Gen as Gen import Test.Hedgehog.Compat @@ -23,7 +22,7 @@ data OpaquePooling :: * where instance Show OpaquePooling where show (OpaquePooling n) = show n -genOpaquePooling :: Monad m => Gen.Gen m OpaquePooling +genOpaquePooling :: Gen OpaquePooling genOpaquePooling = do Just kernelHeight <- someNatVal <$> choose 2 15 Just kernelWidth <- someNatVal <$> choose 2 15 diff --git a/test/Test/Grenade/Network.hs b/test/Test/Grenade/Network.hs index b168a76..0ee0318 100644 --- a/test/Test/Grenade/Network.hs +++ b/test/Test/Grenade/Network.hs @@ -53,7 +53,7 @@ instance Show SomeNetwork where -- -- This is slightly insane for a few reasons. Everything must be wrapped up -- in a SomeNetwork. -genNetwork :: Monad m => Gen.Gen m SomeNetwork +genNetwork :: Gen SomeNetwork genNetwork = Gen.recursive Gen.choice [ do SomeSing ( r :: Sing final ) <- genShape @@ -438,7 +438,7 @@ prop_auto_diff = withDiscards 1000 . withTests 10000 . property $ do result ~~~ expected -- Make a shape where all are 0 except for 1 value, which is 1. -oneUp :: forall shape m. ( Monad m, SingI shape ) => Gen.Gen m (S shape) +oneUp :: forall shape. ( SingI shape ) => Gen (S shape) oneUp = case ( sing :: Sing shape ) of D1Sing SNat -> @@ -482,7 +482,7 @@ maxVal ( S1D x ) = norm_Inf x maxVal ( S2D x ) = norm_Inf x maxVal ( S3D x ) = norm_Inf x -(~~~) :: (Monad m, HasCallStack) => Double -> Double -> Test m () +(~~~) :: (Monad m, HasCallStack) => Double -> Double -> PropertyT m () (~~~) x y = if abs (x - y) < 2e-5 then success diff --git a/test/Test/Grenade/Recurrent/Layers/LSTM.hs b/test/Test/Grenade/Recurrent/Layers/LSTM.hs index 09ddc8f..4f20fb3 100644 --- a/test/Test/Grenade/Recurrent/Layers/LSTM.hs +++ b/test/Test/Grenade/Recurrent/Layers/LSTM.hs @@ -11,7 +11,6 @@ module Test.Grenade.Recurrent.Layers.LSTM where import Hedgehog -import qualified Hedgehog.Gen as Gen import Hedgehog.Internal.Source import Hedgehog.Internal.Show import Hedgehog.Internal.Property ( failWith, Diff (..) ) @@ -29,7 +28,7 @@ import qualified Numeric.LinearAlgebra.Static as S import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference import Test.Hedgehog.Hmatrix -genLSTM :: forall i o m. (KnownNat i, KnownNat o, Monad m) => Gen.Gen m (LSTM i o) +genLSTM :: forall i o. (KnownNat i, KnownNat o) => Gen (LSTM i o) genLSTM = do let w = uniformSample u = uniformSample @@ -103,7 +102,7 @@ prop_lstm_reference_backwards_cell = refGradients = Reference.runLSTMbackOnCell refInput refNet refCell in toList refGradients ~~~ H.toList (S.extract actualGradients) -(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> Test m () +(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> PropertyT m () (~~~) x y = if all (< 1e-8) (zipWith (-) x y) then success diff --git a/test/Test/Hedgehog/Compat.hs b/test/Test/Hedgehog/Compat.hs index 946d554..af759f4 100644 --- a/test/Test/Hedgehog/Compat.hs +++ b/test/Test/Hedgehog/Compat.hs @@ -7,32 +7,24 @@ module Test.Hedgehog.Compat ( , forAllRender )where -import Control.Monad.Trans.Class (MonadTrans(..)) - +import Hedgehog (Gen) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Hedgehog.Internal.Property import Hedgehog.Internal.Source -import Hedgehog.Internal.Show (...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d (...) = (.) . (.) {-# INLINE (...) #-} -choose :: ( Monad m, Integral a ) => a -> a -> Gen.Gen m a +choose :: ( Integral a ) => a -> a -> Gen a choose = Gen.integral ... Range.constant -blindForAll :: Monad m => Gen.Gen m a -> Test m a -blindForAll = Test . lift . lift +blindForAll :: Monad m => Gen a -> PropertyT m a +blindForAll = forAllWith (const "blind") -semiBlindForAll :: (Monad m, Show a, HasCallStack) => Gen.Gen m a -> Test m a -semiBlindForAll gen = do - x <- Test . lift $ lift gen - withFrozenCallStack $ annotate (showPretty x) - return x +semiBlindForAll :: (Monad m, Show a, HasCallStack) => Gen a -> PropertyT m a +semiBlindForAll = forAllWith (const "blind") -forAllRender :: (Monad m, HasCallStack) => ( a -> String ) -> Gen.Gen m a -> Test m a -forAllRender render gen = do - x <- Test . lift $ lift gen - withFrozenCallStack $ footnote (render x) - return x +forAllRender :: (Monad m, HasCallStack) => ( a -> String ) -> Gen a -> PropertyT m a +forAllRender render gen = forAllWith render gen diff --git a/test/Test/Hedgehog/Hmatrix.hs b/test/Test/Hedgehog/Hmatrix.hs index 8f05872..dc2f82a 100644 --- a/test/Test/Hedgehog/Hmatrix.hs +++ b/test/Test/Hedgehog/Hmatrix.hs @@ -9,19 +9,20 @@ import Grenade import Data.Singletons import Data.Singletons.TypeLits +import Hedgehog (Gen) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import qualified Numeric.LinearAlgebra.Static as HStatic -randomVector :: forall m n. ( Monad m, KnownNat n ) => Gen.Gen m (HStatic.R n) +randomVector :: forall n. ( KnownNat n ) => Gen (HStatic.R n) randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded -uniformSample :: forall mm m n. ( Monad mm, KnownNat m, KnownNat n ) => Gen.Gen mm (HStatic.L m n) +uniformSample :: forall m n. ( KnownNat m, KnownNat n ) => Gen (HStatic.L m n) uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded -- | Generate random data of the desired shape -genOfShape :: forall m x. ( Monad m, SingI x ) => Gen.Gen m (S x) +genOfShape :: forall x. ( SingI x ) => Gen (S x) genOfShape = case (sing :: Sing x) of D1Sing l -> diff --git a/test/Test/Hedgehog/TypeLits.hs b/test/Test/Hedgehog/TypeLits.hs index 6742263..27d11eb 100644 --- a/test/Test/Hedgehog/TypeLits.hs +++ b/test/Test/Hedgehog/TypeLits.hs @@ -13,6 +13,7 @@ import Data.Proxy #endif import Data.Singletons +import Hedgehog (Gen) import qualified Hedgehog.Gen as Gen import Grenade @@ -21,7 +22,7 @@ import GHC.TypeLits import GHC.TypeLits.Witnesses import Test.Hedgehog.Compat -genNat :: Monad m => Gen.Gen m SomeNat +genNat :: Gen SomeNat genNat = do Just n <- someNatVal <$> choose 1 10 return n @@ -32,7 +33,7 @@ type Shape' = ('KProxy :: KProxy Shape) type Shape' = Shape #endif -genShape :: Monad m => Gen.Gen m (SomeSing Shape') +genShape :: Gen (SomeSing Shape') genShape = Gen.choice [ genD1 @@ -40,20 +41,20 @@ genShape , genD3 ] -genD1 :: Monad m => Gen.Gen m (SomeSing Shape') +genD1 :: Gen (SomeSing Shape') genD1 = do n <- genNat return $ case n of SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x)) -genD2 :: Monad m => Gen.Gen m (SomeSing Shape') +genD2 :: Gen (SomeSing Shape') genD2 = do n <- genNat m <- genNat return $ case (n, m) of (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y)) -genD3 :: Monad m => Gen.Gen m (SomeSing Shape') +genD3 :: Gen (SomeSing Shape') genD3 = do n <- genNat m <- genNat