git.iko.soy/grenade
on master help sign in
Move tests to hedgehog.
da810e6Huw Campbell
.gitmodulesdeleted−3
compare with master
unifiedsplit
@@ -1,3 +0,0 @@
1−[submodule "lib/haskell-hedgehog"]
2− path = lib/haskell-hedgehog
3− url = git@github.com:hedgehogqa/haskell-hedgehog.git
grenade.cabal+2−4
@@ -125,16 +125,14 @@ test-suite test
125 build-depends:
125 build-depends:
126 base >= 4.8 && < 5
126 base >= 4.8 && < 5
127 , grenade
127 , grenade
128− , ambiata-disorder-core
128+ , hedgehog >= 0.1 && < 0.2
129− , ambiata-disorder-jack
130 , hmatrix
129 , hmatrix
131 , mtl
130 , mtl
132 , singletons
131 , singletons
133 , text == 1.2.*
132 , text == 1.2.*
134 , typelits-witnesses
133 , typelits-witnesses
134+ , transformers
135 , constraints
135 , constraints
136− , QuickCheck >= 2.7 && < 2.9
137− , quickcheck-instances == 0.3.*
138 , MonadRandom
136 , MonadRandom
139 , random
137 , random
140 , ad
138 , ad
lib/haskell-hedgehogdeleted−1

Submodule changed.

test/Test/Grenade/Layers/Convolution.hs+18−18
@@ -18,10 +18,12 @@ import GHC.TypeLits.Witnesses
18import Grenade.Core
18import Grenade.Core
19import Grenade.Layers.Convolution
19import Grenade.Layers.Convolution
20
20
21−import Disorder.Jack
21+import Hedgehog
22+import qualified Hedgehog.Gen as Gen
22
23
23import Test.Jack.Hmatrix
24import Test.Jack.Hmatrix
24import Test.Jack.TypeLits
25import Test.Jack.TypeLits
26+import Test.Jack.Compat
25
27
26data OpaqueConvolution :: * where
28data OpaqueConvolution :: * where
27 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution
29 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution
@@ -58,15 +60,15 @@ genOpaqueOpaqueConvolution = do
58 in case p1 %* p2 %* p3 of
60 in case p1 %* p2 %* p3 of
59 Dict -> OpaqueConvolution <$> (genConvolution :: Jack (Convolution ch fl kr kc sr sc))
61 Dict -> OpaqueConvolution <$> (genConvolution :: Jack (Convolution ch fl kr kc sr sc))
60
62
61−prop_conv_net_witness =
63+prop_conv_net_witness = property $
62− gamble genOpaqueOpaqueConvolution $ \onet ->
64+ forAll genOpaqueOpaqueConvolution >>= \onet ->
63− (case onet of
65+ case onet of
64− (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> True
66+ (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> success
65− ) :: Bool
66
67
68+
67−prop_conv_net =
69+prop_conv_net = property $
68− gamble genOpaqueOpaqueConvolution $ \onet ->
70+ forAll genOpaqueOpaqueConvolution >>= \onet ->
69− (case onet of
71+ case onet of
70 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->
72 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->
71 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]
73 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]
72 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
74 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
@@ -74,15 +76,15 @@ prop_conv_net =
74 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)
76 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)
75 sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)
77 sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)
76
78
77− in gamble (elements (ok sr kr)) $ \er ->
79+ in forAll (Gen.element (ok sr kr)) >>= \er ->
78− gamble (elements (ok sc kc)) $ \ec ->
80+ forAll (Gen.element (ok sc kc)) >>= \ec ->
79 let rr = ((er - kr) `div` sr) + 1
81 let rr = ((er - kr) `div` sr) + 1
80 rc = ((ec - kc) `div` sc) + 1
82 rc = ((ec - kc) `div` sc) + 1
81 Just er' = someNatVal er
83 Just er' = someNatVal er
82 Just ec' = someNatVal ec
84 Just ec' = someNatVal ec
83 Just rr' = someNatVal rr
85 Just rr' = someNatVal rr
84 Just rc' = someNatVal rc
86 Just rc' = someNatVal rc
85− in (case (er', ec', rr', rc') of
87+ in case (er', ec', rr', rc') of
86 ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->
88 ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->
87 case ( natDict pinr %* natDict (Proxy :: Proxy channels)
89 case ( natDict pinr %* natDict (Proxy :: Proxy channels)
88 , natDict pour %* natDict (Proxy :: Proxy filters)
90 , natDict pour %* natDict (Proxy :: Proxy filters)
@@ -90,14 +92,12 @@ prop_conv_net =
90 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
92 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
91 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
93 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
92 (Dict, Dict, Dict, Dict) ->
94 (Dict, Dict, Dict, Dict) ->
93− gamble (S3D <$> uniformSample) $ \(input :: S ('D3 inRows inCols channels)) ->
95+ forAll (S3D <$> uniformSample) >>= \(input :: S ('D3 inRows inCols channels)) ->
94 let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input
96 let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input
95 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))
97 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))
96 = runBackwards convLayer tape output
98 = runBackwards convLayer tape output
97− in backed `seq` True
99+ in backed `seq` success
98− ) :: Property
100+
99− ) :: Property
100
101
101−return []
102tests :: IO Bool
102tests :: IO Bool
103−tests = $quickCheckAll
103+tests = $$(checkConcurrent)
test/Test/Grenade/Layers/FullyConnected.hs+13−13
@@ -15,9 +15,10 @@ import GHC.TypeLits
15import Grenade.Core
15import Grenade.Core
16import Grenade.Layers.FullyConnected
16import Grenade.Layers.FullyConnected
17
17
18−import Disorder.Jack
18+import Hedgehog
19
19
20import Test.Jack.Hmatrix
20import Test.Jack.Hmatrix
21+import Test.Jack.Compat
21
22
22
23
23data OpaqueFullyConnected :: * where
24data OpaqueFullyConnected :: * where
@@ -28,8 +29,8 @@ instance Show OpaqueFullyConnected where
28
29
29genOpaqueFullyConnected :: Jack OpaqueFullyConnected
30genOpaqueFullyConnected :: Jack OpaqueFullyConnected
30genOpaqueFullyConnected = do
31genOpaqueFullyConnected = do
31− input :: Integer <- choose (2, 100)
32+ input :: Integer <- choose 2 100
32− output :: Integer <- choose (1, 100)
33+ output :: Integer <- choose 1 100
33 let Just input' = someNatVal input
34 let Just input' = someNatVal input
34 let Just output' = someNatVal output
35 let Just output' = someNatVal output
35 case (input', output') of
36 case (input', output') of
@@ -41,14 +42,13 @@ genOpaqueFullyConnected = do
41 return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')
42 return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')
42
43
43prop_fully_connected_forwards :: Property
44prop_fully_connected_forwards :: Property
44−prop_fully_connected_forwards =
45+prop_fully_connected_forwards = property $ do
45− gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->
46+ OpaqueFullyConnected (fclayer :: FullyConnected i o) <- forAll genOpaqueFullyConnected
46− gamble (S1D <$> randomVector) $ \(input :: S ('D1 i)) ->
47+ input :: S ('D1 i) <- forAll (S1D <$> randomVector)
47− let (tape, output :: S ('D1 o)) = runForwards fclayer input
48+ let (tape, output :: S ('D1 o)) = runForwards fclayer input
48− backed :: (Gradient (FullyConnected i o), S ('D1 i))
49+ backed :: (Gradient (FullyConnected i o), S ('D1 i))
49− = runBackwards fclayer tape output
50+ = runBackwards fclayer tape output
50− in backed `seq` True
51+ backed `seq` success
51−
52+
52−return []
53tests :: IO Bool
53tests :: IO Bool
54−tests = $quickCheckAll
54+tests = $$(checkConcurrent)
test/Test/Grenade/Layers/Internal/Convolution.hs+34−27
@@ -12,41 +12,48 @@ import Grenade.Layers.Internal.Convolution
12
12
13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
14
14
15−import Disorder.Jack
15+import Hedgehog
16+import qualified Hedgehog.Gen as Gen
17+import qualified Hedgehog.Range as Range
16
18
17import qualified Test.Grenade.Layers.Internal.Reference as Reference
19import qualified Test.Grenade.Layers.Internal.Reference as Reference
20+import Test.Jack.Compat
18
21
19prop_im2col_col2im_symmetrical_with_kernel_stride =
22prop_im2col_col2im_symmetrical_with_kernel_stride =
20 let factors n = [x | x <- [1..n], n `mod` x == 0]
23 let factors n = [x | x <- [1..n], n `mod` x == 0]
21− in gamble (choose (2, 100)) $ \height ->
24+ in property $ do
25+ height <- forAll $ choose 2 100
22− gamble (choose (2, 100)) $ \width ->
26+ width <- forAll $ choose 2 100
23− gamble ((height `div`) <$> elements (factors height)) $ \kernel_h ->
27+ kernel_h <- forAll $ (height `div`) <$> Gen.element (factors height)
24− gamble ((width `div`) <$> elements (factors width)) $ \kernel_w ->
28+ kernel_w <- forAll $ (width `div`) <$> Gen.element (factors width)
25− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
29+ input <- forAll $ Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)
30+
26− let input' = (height >< width) input
31+ let input' = (height >< width) input
27− stride_h = kernel_h
32+ let stride_h = kernel_h
28− stride_w = kernel_w
33+ let stride_w = kernel_w
29− out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input'
34+ let out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input'
30− in input' === out
35+ input' === out
31
36
32prop_im2col_col2im_behaves_as_reference =
37prop_im2col_col2im_behaves_as_reference =
33 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
38 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
39+ in property $ do
34− in gamble (choose (2, 100)) $ \height ->
40+ height <- forAll (choose 2 100)
35− gamble (choose (2, 100)) $ \width ->
41+ width <- forAll (choose 2 100)
36− gamble (choose (2, height - 1)) $ \kernel_h ->
42+ kernel_h <- forAll (choose 2 (height - 1))
37− gamble (choose (2, width - 1)) $ \kernel_w ->
43+ kernel_w <- forAll (choose 2 (width - 1))
38− gamble (elements (ok height kernel_h)) $ \stride_h ->
44+ stride_h <- forAll (Gen.element (ok height kernel_h))
39− gamble (elements (ok width kernel_w)) $ \stride_w ->
45+ stride_w <- forAll (Gen.element (ok width kernel_w))
40− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
46+ input <- forAll ( Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100))
41− let input' = (height >< width) input
47+ let input' = (height >< width) input
42− outFast = im2col kernel_h kernel_w stride_h stride_w input'
48+ let outFast = im2col kernel_h kernel_w stride_h stride_w input'
43− retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast
49+ let retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast
44−
50+
45− outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input'
51+ let outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input'
46− retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference
52+ let retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference
53+
47− in outFast === outReference .&&. retFast === retReference
54+ outFast === outReference
48−
55+ retFast === retReference
49
56
50return []
57return []
51tests :: IO Bool
58tests :: IO Bool
52−tests = $quickCheckAll
59+tests = $$(checkConcurrent)
test/Test/Grenade/Layers/Internal/Pooling.hs+25−18
@@ -12,28 +12,35 @@ import Grenade.Layers.Internal.Pooling
12
12
13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
14
14
15−import Disorder.Jack
15+import Hedgehog
16+import qualified Hedgehog.Gen as Gen
17+import qualified Hedgehog.Range as Range
16
18
17import qualified Test.Grenade.Layers.Internal.Reference as Reference
19import qualified Test.Grenade.Layers.Internal.Reference as Reference
20+import Test.Jack.Compat
18
21
19prop_poolForwards_poolBackwards_behaves_as_reference =
22prop_poolForwards_poolBackwards_behaves_as_reference =
20 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
23 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
21 output extent kernel stride = (extent - kernel) `div` stride + 1
24 output extent kernel stride = (extent - kernel) `div` stride + 1
22− in gamble (choose (2, 100)) $ \height ->
25+ in property $ do
26+ height <- forAll $ choose 2 100
23− gamble (choose (2, 100)) $ \width ->
27+ width <- forAll $ choose 2 100
24− gamble (choose (1, height - 1)) $ \kernel_h ->
28+ kernel_h <- forAll $ choose 1 (height - 1)
25− gamble (choose (1, width - 1)) $ \kernel_w ->
29+ kernel_w <- forAll $ choose 1 (width - 1)
26− gamble (elements (ok height kernel_h)) $ \stride_h ->
30+ stride_h <- forAll $ Gen.element (ok height kernel_h)
27− gamble (elements (ok width kernel_w)) $ \stride_w ->
31+ stride_w <- forAll $ Gen.element (ok width kernel_w)
28− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
32+ input <- forAll $ Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)
33+
29− let input' = (height >< width) input
34+ let input' = (height >< width) input
30− outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'
35+ let outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'
31− retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast
36+ let retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast
32−
37+
33− outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'
38+ let outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'
34− retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference
39+ let retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference
40+
35− in outFast === outReference .&&. retFast === retReference
41+ outFast === outReference
36−
42+ retFast === retReference
37−return []
43+
44+
38tests :: IO Bool
45tests :: IO Bool
39−tests = $quickCheckAll
46+tests = $$(checkConcurrent)
test/Test/Grenade/Layers/Nonlinear.hs+24−18
@@ -9,6 +9,9 @@
9{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
9{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
10module Test.Grenade.Layers.Nonlinear where
10module Test.Grenade.Layers.Nonlinear where
11
11
12+
13+import Control.Monad.Trans.Class (MonadTrans(..))
14+
12import Data.Singletons
15import Data.Singletons
13
16
14#if __GLASGOW_HASKELL__ < 800
17#if __GLASGOW_HASKELL__ < 800
@@ -18,60 +21,63 @@ import Data.Proxy
18import Grenade
21import Grenade
19import GHC.TypeLits
22import GHC.TypeLits
20
23
21−import Disorder.Jack
24+import Hedgehog
25+import Hedgehog.Internal.Property ( Test (..) )
22
26
23import Test.Jack.Hmatrix
27import Test.Jack.Hmatrix
24import Test.Jack.TypeLits
28import Test.Jack.TypeLits
25
29
26import Numeric.LinearAlgebra.Static ( norm_Inf )
30import Numeric.LinearAlgebra.Static ( norm_Inf )
27
31
32+-- | Generates a random input for the test by running the provided generator.
33+--
34+blindForAll :: Monad m => Gen m a -> Test m a
35+blindForAll = Test . lift . lift
36+
28prop_sigmoid_grad :: Property
37prop_sigmoid_grad :: Property
29−prop_sigmoid_grad =
38+prop_sigmoid_grad = property $
30− gambleDisplay (const "Shape") genShape $ \case
39+ blindForAll genShape >>= \case
31 (SomeSing (r :: Sing s)) ->
40 (SomeSing (r :: Sing s)) ->
32 withSingI r $
41 withSingI r $
33− gamble genOfShape $ \(ds :: S s) ->
42+ blindForAll genOfShape >>= \(ds :: S s) ->
34 let (tape, f :: S s) = runForwards Logit ds
43 let (tape, f :: S s) = runForwards Logit ds
35 ((), ret :: S s) = runBackwards Logit tape (1 :: S s)
44 ((), ret :: S s) = runBackwards Logit tape (1 :: S s)
36 (_, numer :: S s) = runForwards Logit (ds + 0.0001)
45 (_, numer :: S s) = runForwards Logit (ds + 0.0001)
37 numericalGradient = (numer - f) * 10000
46 numericalGradient = (numer - f) * 10000
38− in counterexample (show numericalGradient ++ show ret)
39− ((case numericalGradient - ret of
47+ in assert ((case numericalGradient - ret of
40 (S1D x) -> norm_Inf x < 0.0001
48 (S1D x) -> norm_Inf x < 0.0001
41 (S2D x) -> norm_Inf x < 0.0001
49 (S2D x) -> norm_Inf x < 0.0001
42 (S3D x) -> norm_Inf x < 0.0001) :: Bool)
50 (S3D x) -> norm_Inf x < 0.0001) :: Bool)
43
51
44prop_tanh_grad :: Property
52prop_tanh_grad :: Property
45−prop_tanh_grad =
53+prop_tanh_grad = property $
46− gambleDisplay (const "Shape") genShape $ \case
54+ blindForAll genShape >>= \case
47 (SomeSing (r :: Sing s)) ->
55 (SomeSing (r :: Sing s)) ->
48 withSingI r $
56 withSingI r $
49− gamble genOfShape $ \(ds :: S s) ->
57+ blindForAll genOfShape >>= \(ds :: S s) ->
50 let (tape, f :: S s) = runForwards Tanh ds
58 let (tape, f :: S s) = runForwards Tanh ds
51 ((), ret :: S s) = runBackwards Tanh tape (1 :: S s)
59 ((), ret :: S s) = runBackwards Tanh tape (1 :: S s)
52 (_, numer :: S s) = runForwards Tanh (ds + 0.0001)
60 (_, numer :: S s) = runForwards Tanh (ds + 0.0001)
53 numericalGradient = (numer - f) * 10000
61 numericalGradient = (numer - f) * 10000
54− in counterexample (show numericalGradient ++ show ret)
55− ((case numericalGradient - ret of
62+ in assert ((case numericalGradient - ret of
56 (S1D x) -> norm_Inf x < 0.001
63 (S1D x) -> norm_Inf x < 0.001
57 (S2D x) -> norm_Inf x < 0.001
64 (S2D x) -> norm_Inf x < 0.001
58 (S3D x) -> norm_Inf x < 0.001) :: Bool)
65 (S3D x) -> norm_Inf x < 0.001) :: Bool)
59
66
60prop_softmax_grad :: Property
67prop_softmax_grad :: Property
61−prop_softmax_grad =
68+prop_softmax_grad = property $
62− gamble genNat $ \case
69+ forAll genNat >>= \case
63 (SomeNat (_ :: Proxy s)) ->
70 (SomeNat (_ :: Proxy s)) ->
64− gamble genOfShape $ \(ds :: S ('D1 s)) ->
71+ forAll genOfShape >>= \(ds :: S ('D1 s)) ->
65 let (tape, f :: S ('D1 s)) = runForwards Relu ds
72 let (tape, f :: S ('D1 s)) = runForwards Relu ds
66 ((), ret :: S ('D1 s)) = runBackwards Relu tape (1 :: S ('D1 s))
73 ((), ret :: S ('D1 s)) = runBackwards Relu tape (1 :: S ('D1 s))
67 (_, numer :: S ('D1 s)) = runForwards Relu (ds + 0.0001)
74 (_, numer :: S ('D1 s)) = runForwards Relu (ds + 0.0001)
68 numericalGradient = (numer - f) * 10000
75 numericalGradient = (numer - f) * 10000
69− in counterexample (show numericalGradient ++ show ret)
70− ((case numericalGradient - ret of
76+ in assert ((case numericalGradient - ret of
71 (S1D x) -> norm_Inf x < 0.0001) :: Bool)
77 (S1D x) -> norm_Inf x < 0.0001) :: Bool)
72
78
73
79
74−return []
80+
75tests :: IO Bool
81tests :: IO Bool
76−tests = $quickCheckAll
82+tests = $$(checkConcurrent)
77
83
test/Test/Grenade/Layers/PadCrop.hs+11−7
@@ -15,7 +15,7 @@ module Test.Grenade.Layers.PadCrop where
15
15
16import Grenade
16import Grenade
17
17
18−import Disorder.Jack
18+import Hedgehog
19
19
20import Numeric.LinearAlgebra.Static ( norm_Inf )
20import Numeric.LinearAlgebra.Static ( norm_Inf )
21
21
@@ -25,25 +25,29 @@ prop_pad_crop :: Property
25prop_pad_crop =
25prop_pad_crop =
26 let net :: Network '[Pad 2 3 4 6, Crop 2 3 4 6] '[ 'D3 7 9 5, 'D3 16 15 5, 'D3 7 9 5 ]
26 let net :: Network '[Pad 2 3 4 6, Crop 2 3 4 6] '[ 'D3 7 9 5, 'D3 16 15 5, 'D3 7 9 5 ]
27 net = Pad :~> Crop :~> NNil
27 net = Pad :~> Crop :~> NNil
28+ in property $
28− in gamble genOfShape $ \(d :: S ('D3 7 9 5)) ->
29+ forAll genOfShape >>= \(d :: S ('D3 7 9 5)) ->
29 let (tapes, res) = runForwards net d
30 let (tapes, res) = runForwards net d
30 (_ , grad) = runBackwards net tapes d
31 (_ , grad) = runBackwards net tapes d
31− in d ~~~ res .&&. grad ~~~ d
32+ in do assert $ d ~~~ res
33+ assert $ grad ~~~ d
32
34
33prop_pad_crop_2d :: Property
35prop_pad_crop_2d :: Property
34prop_pad_crop_2d =
36prop_pad_crop_2d =
35 let net :: Network '[Pad 2 3 4 6, Crop 2 3 4 6] '[ 'D2 7 9, 'D2 16 15, 'D2 7 9 ]
37 let net :: Network '[Pad 2 3 4 6, Crop 2 3 4 6] '[ 'D2 7 9, 'D2 16 15, 'D2 7 9 ]
36 net = Pad :~> Crop :~> NNil
38 net = Pad :~> Crop :~> NNil
39+ in property $
37− in gamble genOfShape $ \(d :: S ('D2 7 9)) ->
40+ forAll genOfShape >>= \(d :: S ('D2 7 9)) ->
38 let (tapes, res) = runForwards net d
41 let (tapes, res) = runForwards net d
39 (_ , grad) = runBackwards net tapes d
42 (_ , grad) = runBackwards net tapes d
40− in d ~~~ res .&&. grad ~~~ d
43+ in do assert $ d ~~~ res
44+ assert $ grad ~~~ d
41
45
42(~~~) :: S x -> S x -> Bool
46(~~~) :: S x -> S x -> Bool
43(S1D x) ~~~ (S1D y) = norm_Inf (x - y) < 0.00001
47(S1D x) ~~~ (S1D y) = norm_Inf (x - y) < 0.00001
44(S2D x) ~~~ (S2D y) = norm_Inf (x - y) < 0.00001
48(S2D x) ~~~ (S2D y) = norm_Inf (x - y) < 0.00001
45(S3D x) ~~~ (S3D y) = norm_Inf (x - y) < 0.00001
49(S3D x) ~~~ (S3D y) = norm_Inf (x - y) < 0.00001
46
50
47−return []
51+
48tests :: IO Bool
52tests :: IO Bool
49−tests = $quickCheckAll
53+tests = $$(checkConcurrent)
test/Test/Grenade/Layers/Pooling.hs+12−13
@@ -12,8 +12,8 @@ import Data.Singletons ()
12import GHC.TypeLits
12import GHC.TypeLits
13import Grenade.Layers.Pooling
13import Grenade.Layers.Pooling
14
14
15−import Disorder.Jack
15+import Hedgehog
16−
16+import Test.Jack.Compat
17
17
18data OpaquePooling :: * where
18data OpaquePooling :: * where
19 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling
19 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling
@@ -23,22 +23,21 @@ instance Show OpaquePooling where
23
23
24genOpaquePooling :: Jack OpaquePooling
24genOpaquePooling :: Jack OpaquePooling
25genOpaquePooling = do
25genOpaquePooling = do
26− Just kernelHeight <- someNatVal <$> choose (2, 15)
26+ Just kernelHeight <- someNatVal <$> choose 2 15
27− Just kernelWidth <- someNatVal <$> choose (2, 15)
27+ Just kernelWidth <- someNatVal <$> choose 2 15
28− Just strideHeight <- someNatVal <$> choose (2, 15)
28+ Just strideHeight <- someNatVal <$> choose 2 15
29− Just strideWidth <- someNatVal <$> choose (2, 15)
29+ Just strideWidth <- someNatVal <$> choose 2 15
30
30
31 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of
31 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of
32 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->
32 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->
33 return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)
33 return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)
34
34
35prop_pool_layer_witness =
35prop_pool_layer_witness =
36+ property $ do
36− gamble genOpaquePooling $ \onet ->
37+ onet <- forAll genOpaquePooling
37− (case onet of
38+ case onet of
38− (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) -> True
39+ (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) ->
39− ) :: Bool
40+ assert True
40−
41
41
42−return []
43tests :: IO Bool
42tests :: IO Bool
44−tests = $quickCheckAll
43+tests = $$(checkConcurrent)
test/Test/Grenade/Recurrent/Layers/LSTM.hs+56−49
@@ -10,7 +10,7 @@
10{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
10{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
11module Test.Grenade.Recurrent.Layers.LSTM where
11module Test.Grenade.Recurrent.Layers.LSTM where
12
12
13−import Disorder.Jack
13+import Hedgehog
14
14
15import Data.Foldable ( toList )
15import Data.Foldable ( toList )
16import Data.Singletons.TypeLits
16import Data.Singletons.TypeLits
@@ -24,6 +24,7 @@ import qualified Numeric.LinearAlgebra.Static as S
24
24
25import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference
25import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference
26import Test.Jack.Hmatrix
26import Test.Jack.Hmatrix
27+import Test.Jack.Compat
27
28
28genLSTM :: forall i o. (KnownNat i, KnownNat o) => Jack (LSTM i o)
29genLSTM :: forall i o. (KnownNat i, KnownNat o) => Jack (LSTM i o)
29genLSTM = do
30genLSTM = do
@@ -39,63 +40,69 @@ genLSTM = do
39 <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)
40 <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)
40
41
41prop_lstm_reference_forwards =
42prop_lstm_reference_forwards =
42− gamble randomVector $ \(input :: S.R 3) ->
43+ property $ do
43− gamble randomVector $ \(cell :: S.R 2) ->
44+ input :: S.R 3 <- forAll randomVector
44− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
45+ cell :: S.R 2 <- forAll randomVector
46+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
47+
45− let actual = runRecurrentForwards net (S1D cell) (S1D input)
48+ let actual = runRecurrentForwards net (S1D cell) (S1D input)
46− in case actual of
49+ case actual of
47− (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->
50+ (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->
48− let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut
51+ let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut
49− output' = Reference.Vector . H.toList . S.extract $ output
52+ output' = Reference.Vector . H.toList . S.extract $ output
50− refNet = Reference.lstmToReference lstmWeights
53+ refNet = Reference.lstmToReference lstmWeights
51− refCell = Reference.Vector . H.toList . S.extract $ cell
54+ refCell = Reference.Vector . H.toList . S.extract $ cell
52− refInput = Reference.Vector . H.toList . S.extract $ input
55+ refInput = Reference.Vector . H.toList . S.extract $ input
53− (refCO, refO) = Reference.runLSTM refNet refCell refInput
56+ (refCO, refO) = Reference.runLSTM refNet refCell refInput
54− in toList refCO ~~~ toList cellOut' .&&. toList refO ~~~ toList output'
57+ in do assert (toList refCO ~~~ toList cellOut')
58+ assert (toList refO ~~~ toList output')
59+
55
60
56prop_lstm_reference_backwards =
61prop_lstm_reference_backwards =
57− gamble randomVector $ \(input :: S.R 3) ->
62+ property $ do
58− gamble randomVector $ \(cell :: S.R 2) ->
63+ input :: S.R 3 <- forAll randomVector
59− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
64+ cell :: S.R 2 <- forAll randomVector
65+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
60− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
66+ let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
61− in case actualBacks of
67+ case actualBacks of
62− (actualGradients, _, _ :: S ('D1 3)) ->
68+ (actualGradients, _, _ :: S ('D1 3)) ->
63− let refNet = Reference.lstmToReference lstmWeights
69+ let refNet = Reference.lstmToReference lstmWeights
64− refCell = Reference.Vector . H.toList . S.extract $ cell
70+ refCell = Reference.Vector . H.toList . S.extract $ cell
65− refInput = Reference.Vector . H.toList . S.extract $ input
71+ refInput = Reference.Vector . H.toList . S.extract $ input
66− refGradients = Reference.runLSTMback refCell refInput refNet
72+ refGradients = Reference.runLSTMback refCell refInput refNet
67− in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)
73+ in assert $ toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)
68
74
69prop_lstm_reference_backwards_input =
75prop_lstm_reference_backwards_input =
70− gamble randomVector $ \(input :: S.R 3) ->
76+ property $ do
71− gamble randomVector $ \(cell :: S.R 2) ->
77+ input :: S.R 3 <- forAll randomVector
72− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
78+ cell :: S.R 2 <- forAll randomVector
79+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
73− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
80+ let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
74− in case actualBacks of
81+ case actualBacks of
75− (_, _, S1D actualGradients :: S ('D1 3)) ->
82+ (_, _, S1D actualGradients :: S ('D1 3)) ->
76− let refNet = Reference.lstmToReference lstmWeights
83+ let refNet = Reference.lstmToReference lstmWeights
77− refCell = Reference.Vector . H.toList . S.extract $ cell
84+ refCell = Reference.Vector . H.toList . S.extract $ cell
78− refInput = Reference.Vector . H.toList . S.extract $ input
85+ refInput = Reference.Vector . H.toList . S.extract $ input
79− refGradients = Reference.runLSTMbackOnInput refCell refNet refInput
86+ refGradients = Reference.runLSTMbackOnInput refCell refNet refInput
80− in toList refGradients ~~~ H.toList (S.extract actualGradients)
87+ in assert $ toList refGradients ~~~ H.toList (S.extract actualGradients)
81
88
82prop_lstm_reference_backwards_cell =
89prop_lstm_reference_backwards_cell =
83− gamble randomVector $ \(input :: S.R 3) ->
90+ property $ do
84− gamble randomVector $ \(cell :: S.R 2) ->
91+ input :: S.R 3 <- forAll randomVector
85− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
92+ cell :: S.R 2 <- forAll randomVector
93+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
86− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
94+ let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
87− in case actualBacks of
95+ case actualBacks of
88− (_, S1D actualGradients, _ :: S ('D1 3)) ->
96+ (_, S1D actualGradients, _ :: S ('D1 3)) ->
89− let refNet = Reference.lstmToReference lstmWeights
97+ let refNet = Reference.lstmToReference lstmWeights
90− refCell = Reference.Vector . H.toList . S.extract $ cell
98+ refCell = Reference.Vector . H.toList . S.extract $ cell
91− refInput = Reference.Vector . H.toList . S.extract $ input
99+ refInput = Reference.Vector . H.toList . S.extract $ input
92− refGradients = Reference.runLSTMbackOnCell refInput refNet refCell
100+ refGradients = Reference.runLSTMbackOnCell refInput refNet refCell
93− in toList refGradients ~~~ H.toList (S.extract actualGradients)
101+ in assert $ toList refGradients ~~~ H.toList (S.extract actualGradients)
94
102
95
103
96(~~~) as bs = all (< 1e-8) (zipWith (-) as bs)
104(~~~) as bs = all (< 1e-8) (zipWith (-) as bs)
97infix 4 ~~~
105infix 4 ~~~
98
106
99−return []
100tests :: IO Bool
107tests :: IO Bool
101−tests = $quickCheckAll
108+tests = $$(checkConcurrent)
test/Test/Jack/Hmatrix.hs+5−3
@@ -8,17 +8,19 @@ module Test.Jack.Hmatrix where
8import Grenade
8import Grenade
9import Data.Singletons
9import Data.Singletons
10
10
11−import Disorder.Jack
11+import qualified Hedgehog.Gen as Gen
12+import qualified Hedgehog.Range as Range
12
13
13import GHC.TypeLits
14import GHC.TypeLits
14
15
15import qualified Numeric.LinearAlgebra.Static as HStatic
16import qualified Numeric.LinearAlgebra.Static as HStatic
17+import Test.Jack.Compat
16
18
17randomVector :: forall n. KnownNat n => Jack (HStatic.R n)
19randomVector :: forall n. KnownNat n => Jack (HStatic.R n)
18−randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> sizedNat
20+randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded
19
21
20uniformSample :: forall m n. (KnownNat m, KnownNat n) => Jack (HStatic.L m n)
22uniformSample :: forall m n. (KnownNat m, KnownNat n) => Jack (HStatic.L m n)
21−uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> sizedNat
23+uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded
22
24
23-- | Generate random data of the desired shape
25-- | Generate random data of the desired shape
24genOfShape :: forall x. ( SingI x ) => Jack (S x)
26genOfShape :: forall x. ( SingI x ) => Jack (S x)
test/Test/Jack/TypeLits.hs+5−3
@@ -10,16 +10,18 @@ import Data.Constraint
10import Data.Proxy
10import Data.Proxy
11#endif
11#endif
12import Data.Singletons
12import Data.Singletons
13−import Disorder.Jack
13+
14+import qualified Hedgehog.Gen as Gen
14
15
15import Grenade
16import Grenade
16
17
17import GHC.TypeLits
18import GHC.TypeLits
18import GHC.TypeLits.Witnesses
19import GHC.TypeLits.Witnesses
20+import Test.Jack.Compat
19
21
20genNat :: Jack SomeNat
22genNat :: Jack SomeNat
21genNat = do
23genNat = do
22− Just n <- someNatVal <$> choose (1, 10)
24+ Just n <- someNatVal <$> choose 1 10
23 return n
25 return n
24
26
25#if __GLASGOW_HASKELL__ < 800
27#if __GLASGOW_HASKELL__ < 800
@@ -30,7 +32,7 @@ type Shape' = Shape
30
32
31genShape :: Jack (SomeSing Shape')
33genShape :: Jack (SomeSing Shape')
32genShape
34genShape
33− = oneOf [
35+ = Gen.choice [
34 genD1
36 genD1
35 , genD2
37 , genD2
36 , genD3
38 , genD3