HuwCampbell/grenade
1
1
Fork 0
mirror of https://github.com/HuwCampbell/grenade.git synced 2024-11-22 06:55:13 +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:
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

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

@ -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 ->

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

@ -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

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

@ -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

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
-- 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

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

@ -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

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

@ -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

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

@ -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 ->

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

@ -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