HuwCampbell/grenade
1
1
Fork 0
mirror of https://github.com/HuwCampbell/grenade.git synced 2024-11-25 13:43:03 +03:00
Code Issues Projects Releases Wiki Activity

Bump hedgehog and criterion

Browse Source
This commit is contained in:
Huw Campbell 2017-12-14 16:05:37 +11:00
parent a8ffdbc5d6
commit 6e43a16a77
9 changed files with 30 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
grenade.cabal
View File

@ -150,7 +150,7 @@ test-suite test
build-depends: build-depends:
base >= 4.8 && < 5 base >= 4.8 && < 5
, grenade , grenade
, hedgehog >= 0.4 && < 0.5 , hedgehog >= 0.5 && < 0.6
, hmatrix , hmatrix
, mtl , mtl
, singletons , singletons
@ -178,7 +178,7 @@ benchmark bench
build-depends: build-depends:
base >= 3 && < 5 base >= 3 && < 5
, bytestring == 0.10.* , bytestring == 0.10.*
, criterion == 1.1.* , criterion >= 1.1 && < 1.3
, grenade , grenade
, hmatrix , hmatrix

7
test/Test/Grenade/Layers/Convolution.hs
View File

@ -39,11 +39,10 @@ genConvolution :: ( KnownNat channels
, KnownNat strideColumns , KnownNat strideColumns
, KnownNat kernelFlattened , KnownNat kernelFlattened
, kernelFlattened ~ (kernelRows * kernelColumns * channels) , kernelFlattened ~ (kernelRows * kernelColumns * channels)
, Monad m ) => Gen (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)
) => Gen.Gen m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)
genConvolution = Convolution <$> uniformSample <*> uniformSample genConvolution = Convolution <$> uniformSample <*> uniformSample
genOpaqueOpaqueConvolution :: Monad m => Gen m OpaqueConvolution genOpaqueOpaqueConvolution :: Gen OpaqueConvolution
genOpaqueOpaqueConvolution = do genOpaqueOpaqueConvolution = do
channels <- genNat channels <- genNat
filters <- genNat filters <- genNat
@ -59,7 +58,7 @@ genOpaqueOpaqueConvolution = do
p2 = natDict pkc p2 = natDict pkc
p3 = natDict pch p3 = natDict pch
in case p1 %* p2 %* p3 of 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 $ prop_conv_net_witness = property $
blindForAll genOpaqueOpaqueConvolution >>= \onet -> blindForAll genOpaqueOpaqueConvolution >>= \onet ->

2
test/Test/Grenade/Layers/FullyConnected.hs
View File

@ -26,7 +26,7 @@ data OpaqueFullyConnected :: * where
instance Show OpaqueFullyConnected where instance Show OpaqueFullyConnected where
show (OpaqueFullyConnected n) = show n show (OpaqueFullyConnected n) = show n
genOpaqueFullyConnected :: Monad m => Gen m OpaqueFullyConnected genOpaqueFullyConnected :: Gen OpaqueFullyConnected
genOpaqueFullyConnected = do genOpaqueFullyConnected = do
input :: Integer <- choose 2 100 input :: Integer <- choose 2 100
output :: Integer <- choose 1 100 output :: Integer <- choose 1 100

3
test/Test/Grenade/Layers/Pooling.hs
View File

@ -13,7 +13,6 @@ import GHC.TypeLits
import Grenade.Layers.Pooling import Grenade.Layers.Pooling
import Hedgehog import Hedgehog
import qualified Hedgehog.Gen as Gen
import Test.Hedgehog.Compat import Test.Hedgehog.Compat
@ -23,7 +22,7 @@ data OpaquePooling :: * where
instance Show OpaquePooling where instance Show OpaquePooling where
show (OpaquePooling n) = show n show (OpaquePooling n) = show n
genOpaquePooling :: Monad m => Gen.Gen m OpaquePooling genOpaquePooling :: Gen OpaquePooling
genOpaquePooling = do genOpaquePooling = do
Just kernelHeight <- someNatVal <$> choose 2 15 Just kernelHeight <- someNatVal <$> choose 2 15
Just kernelWidth <- someNatVal <$> choose 2 15 Just kernelWidth <- someNatVal <$> choose 2 15

6
test/Test/Grenade/Network.hs
View File

@ -53,7 +53,7 @@ instance Show SomeNetwork where
-- --
-- This is slightly insane for a few reasons. Everything must be wrapped up -- This is slightly insane for a few reasons. Everything must be wrapped up
-- in a SomeNetwork. -- in a SomeNetwork.
genNetwork :: Monad m => Gen.Gen m SomeNetwork genNetwork :: Gen SomeNetwork
genNetwork = genNetwork =
Gen.recursive Gen.choice [ Gen.recursive Gen.choice [
do SomeSing ( r :: Sing final ) <- genShape do SomeSing ( r :: Sing final ) <- genShape
@ -438,7 +438,7 @@ prop_auto_diff = withDiscards 1000 . withTests 10000 . property $ do
result ~~~ expected result ~~~ expected
-- Make a shape where all are 0 except for 1 value, which is 1. -- 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 = oneUp =
case ( sing :: Sing shape ) of case ( sing :: Sing shape ) of
D1Sing SNat -> D1Sing SNat ->
@ -482,7 +482,7 @@ maxVal ( S1D x ) = norm_Inf x
maxVal ( S2D x ) = norm_Inf x maxVal ( S2D x ) = norm_Inf x
maxVal ( S3D 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 = (~~~) x y =
if abs (x - y) < 2e-5 then if abs (x - y) < 2e-5 then
success success

5
test/Test/Grenade/Recurrent/Layers/LSTM.hs
View File

@ -11,7 +11,6 @@
module Test.Grenade.Recurrent.Layers.LSTM where module Test.Grenade.Recurrent.Layers.LSTM where
import Hedgehog import Hedgehog
import qualified Hedgehog.Gen as Gen
import Hedgehog.Internal.Source import Hedgehog.Internal.Source
import Hedgehog.Internal.Show import Hedgehog.Internal.Show
import Hedgehog.Internal.Property ( failWith, Diff (..) ) 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 qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference
import Test.Hedgehog.Hmatrix 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 genLSTM = do
let w = uniformSample let w = uniformSample
u = uniformSample u = uniformSample
@ -103,7 +102,7 @@ prop_lstm_reference_backwards_cell =
refGradients = Reference.runLSTMbackOnCell refInput refNet refCell refGradients = Reference.runLSTMbackOnCell refInput refNet refCell
in toList refGradients ~~~ H.toList (S.extract actualGradients) 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 = (~~~) x y =
if all (< 1e-8) (zipWith (-) x y) then if all (< 1e-8) (zipWith (-) x y) then
success success

24
test/Test/Hedgehog/Compat.hs
View File

@ -7,32 +7,24 @@ module Test.Hedgehog.Compat (
, forAllRender , forAllRender
)where )where
import Control.Monad.Trans.Class (MonadTrans(..)) import Hedgehog (Gen)
import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range import qualified Hedgehog.Range as Range
import Hedgehog.Internal.Property import Hedgehog.Internal.Property
import Hedgehog.Internal.Source import Hedgehog.Internal.Source
import Hedgehog.Internal.Show
(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d (...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(...) = (.) . (.) (...) = (.) . (.)
{-# INLINE (...) #-} {-# INLINE (...) #-}
choose :: ( Monad m, Integral a ) => a -> a -> Gen.Gen m a choose :: ( Integral a ) => a -> a -> Gen a
choose = Gen.integral ... Range.constant choose = Gen.integral ... Range.constant
blindForAll :: Monad m => Gen.Gen m a -> Test m a blindForAll :: Monad m => Gen a -> PropertyT m a
blindForAll = Test . lift . lift blindForAll = forAllWith (const "blind")
semiBlindForAll :: (Monad m, Show a, HasCallStack) => Gen.Gen m a -> Test m a semiBlindForAll :: (Monad m, Show a, HasCallStack) => Gen a -> PropertyT m a
semiBlindForAll gen = do semiBlindForAll = forAllWith (const "blind")
x <- Test . lift $ lift gen
withFrozenCallStack $ annotate (showPretty x)
return x
forAllRender :: (Monad m, HasCallStack) => ( a -> String ) -> Gen.Gen m a -> Test m a forAllRender :: (Monad m, HasCallStack) => ( a -> String ) -> Gen a -> PropertyT m a
forAllRender render gen = do forAllRender render gen = forAllWith render gen
x <- Test . lift $ lift gen
withFrozenCallStack $ footnote (render x)
return x

7
test/Test/Hedgehog/Hmatrix.hs
View File

@ -9,19 +9,20 @@ import Grenade
import Data.Singletons import Data.Singletons
import Data.Singletons.TypeLits import Data.Singletons.TypeLits
import Hedgehog (Gen)
import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range import qualified Hedgehog.Range as Range
import qualified Numeric.LinearAlgebra.Static as HStatic 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 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 uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded
-- | Generate random data of the desired shape -- | 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 = genOfShape =
case (sing :: Sing x) of case (sing :: Sing x) of
D1Sing l -> D1Sing l ->

11
test/Test/Hedgehog/TypeLits.hs
View File

@ -13,6 +13,7 @@ import Data.Proxy
#endif #endif
import Data.Singletons import Data.Singletons
import Hedgehog (Gen)
import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Gen as Gen
import Grenade import Grenade
@ -21,7 +22,7 @@ import GHC.TypeLits
import GHC.TypeLits.Witnesses import GHC.TypeLits.Witnesses
import Test.Hedgehog.Compat import Test.Hedgehog.Compat
genNat :: Monad m => Gen.Gen m SomeNat genNat :: Gen SomeNat
genNat = do genNat = do
Just n <- someNatVal <$> choose 1 10 Just n <- someNatVal <$> choose 1 10
return n return n
@ -32,7 +33,7 @@ type Shape' = ('KProxy :: KProxy Shape)
type Shape' = Shape type Shape' = Shape
#endif #endif
genShape :: Monad m => Gen.Gen m (SomeSing Shape') genShape :: Gen (SomeSing Shape')
genShape genShape
= Gen.choice [ = Gen.choice [
genD1 genD1
@ -40,20 +41,20 @@ genShape
, genD3 , genD3
] ]
genD1 :: Monad m => Gen.Gen m (SomeSing Shape') genD1 :: Gen (SomeSing Shape')
genD1 = do genD1 = do
n <- genNat n <- genNat
return $ case n of return $ case n of
SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x)) SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))
genD2 :: Monad m => Gen.Gen m (SomeSing Shape') genD2 :: Gen (SomeSing Shape')
genD2 = do genD2 = do
n <- genNat n <- genNat
m <- genNat m <- genNat
return $ case (n, m) of return $ case (n, m) of
(SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y)) (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 genD3 = do
n <- genNat n <- genNat
m <- genNat m <- genNat