aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ox-arrays.cabal4
-rw-r--r--test/Gen.hs85
-rw-r--r--test/Main.hs151
-rw-r--r--test/Tests/C.hs73
-rw-r--r--test/Util.hs38
5 files changed, 202 insertions, 149 deletions
diff --git a/ox-arrays.cabal b/ox-arrays.cabal
index d0aed82..e53815e 100644
--- a/ox-arrays.cabal
+++ b/ox-arrays.cabal
@@ -35,6 +35,10 @@ library
test-suite test
type: exitcode-stdio-1.0
main-is: Main.hs
+ other-modules:
+ Gen
+ Tests.C
+ Util
build-depends:
ox-arrays,
base,
diff --git a/test/Gen.hs b/test/Gen.hs
new file mode 100644
index 0000000..2d2a30b
--- /dev/null
+++ b/test/Gen.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeAbstractions #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
+module Gen where
+
+import qualified Data.ByteString as BS
+import Data.Foldable (toList)
+import qualified Data.Vector.Storable as VS
+import Foreign
+import GHC.TypeLits
+import qualified GHC.TypeNats as TN
+
+import Data.Array.Mixed (fromSNat', pattern SZ, pattern SS)
+import Data.Array.Nested
+
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import qualified System.Random as Random
+
+import Util
+
+
+genRank :: (forall n. SNat n -> PropertyT IO ()) -> PropertyT IO ()
+genRank k = do
+ rank <- forAll $ Gen.int (Range.linear 0 8)
+ TN.withSomeSNat (fromIntegral rank) k
+
+genLowBiased :: RealFloat a => (a, a) -> Gen a
+genLowBiased (lo, hi) = do
+ x <- Gen.realFloat (Range.linearFrac 0 1)
+ return (lo + x * x * x * (hi - lo))
+
+shuffleShR :: IShR n -> Gen (IShR n)
+shuffleShR = \sh -> go (length (toList sh)) (toList sh) sh
+ where
+ go :: Int -> [Int] -> IShR n -> Gen (IShR n)
+ go _ _ ZSR = return ZSR
+ go nbag bag (_ :$: sh) = do
+ idx <- Gen.int (Range.linear 0 (nbag - 1))
+ let (dim, bag') = case splitAt idx bag of
+ (pre, n : post) -> (n, pre ++ post)
+ _ -> error "unreachable"
+ (dim :$:) <$> go (nbag - 1) bag' sh
+
+genShR :: SNat n -> Gen (IShR n)
+genShR sn = do
+ let n = fromSNat' sn
+ targetSize <- Gen.int (Range.linear 0 100_000)
+ let genDims :: SNat m -> Int -> Gen (IShR m)
+ genDims SZ _ = return ZSR
+ genDims (SS m) 0 = do
+ dim <- Gen.int (Range.linear 0 20)
+ dims <- genDims m 0
+ return (dim :$: dims)
+ genDims (SS m) tgt = do
+ dim <- Gen.frequency [(20 * n, round <$> genLowBiased @Double (2.0, max 2.0 (sqrt (fromIntegral tgt))))
+ ,(2 , return tgt)
+ ,(4 , return 1)
+ ,(1 , return 0)]
+ dims <- genDims m (if dim == 0 then 0 else tgt `div` dim)
+ return (dim :$: dims)
+ dims <- genDims sn targetSize
+ let dimsL = toList dims
+ maxdim = maximum dimsL
+ cap = binarySearch (`div` 2) 1 maxdim (\cap' -> product (min cap' <$> dimsL) <= targetSize)
+ shuffleShR (min cap <$> dims)
+
+genStorables :: forall a. Storable a => Range Int -> (Word64 -> a) -> GenT IO (VS.Vector a)
+genStorables rng f = do
+ n <- Gen.int rng
+ seed <- Gen.resize 99 $ Gen.int Range.linearBounded
+ let gen0 = Random.mkStdGen seed
+ (bs, _) = Random.genByteString (8 * n) gen0
+ let readW64 i = sum (zipWith (*) (iterate (*256) 1) [fromIntegral (bs `BS.index` (8 * i + j)) | j <- [0..7]])
+ return $ VS.generate n (f . readW64)
+
diff --git a/test/Main.hs b/test/Main.hs
index b5237e5..7e62641 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,158 +1,11 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeAbstractions #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}
-{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
module Main where
-import Control.Monad
-import qualified Data.Array.RankedS as OR
-import qualified Data.ByteString as BS
-import Data.Foldable (toList)
-import Data.Type.Equality
-import qualified Data.Vector.Storable as VS
-import Foreign
-import GHC.TypeLits
-import qualified GHC.TypeNats as TN
-
-import qualified Data.Array.Mixed as X
-import Data.Array.Mixed (fromSNat', pattern SZ, pattern SS)
-import Data.Array.Nested
-import qualified Data.Array.Nested.Internal as I
-
--- test framework stuff
-import Hedgehog
-import Hedgehog.Internal.Property (forAllT)
-import qualified Hedgehog.Gen as Gen
-import qualified Hedgehog.Range as Range
-import qualified System.Random as Random
import Test.Tasty
-import Test.Tasty.Hedgehog
-
--- import Debug.Trace
-
-
--- Returns highest value that satisfies the predicate, or `lo` if none does
-binarySearch :: (Num a, Eq a) => (a -> a) -> a -> a -> (a -> Bool) -> a
-binarySearch div2 = \lo hi f -> case (f lo, f hi) of
- (False, _) -> lo
- (_, True) -> hi
- (_, _ ) -> go lo hi f
- where
- go lo hi f = -- invariant: f lo && not (f hi)
- let mid = lo + div2 (hi - lo)
- in if mid `elem` [lo, hi]
- then mid
- else if f mid then go mid hi f else go lo mid f
-
-genRank :: (forall n. SNat n -> PropertyT IO ()) -> PropertyT IO ()
-genRank k = do
- rank <- forAll $ Gen.int (Range.linear 0 8)
- TN.withSomeSNat (fromIntegral rank) k
-genLowBiased :: RealFloat a => (a, a) -> Gen a
-genLowBiased (lo, hi) = do
- x <- Gen.realFloat (Range.linearFrac 0 1)
- return (lo + x * x * x * (hi - lo))
+import qualified Tests.C
-shuffleShR :: IShR n -> Gen (IShR n)
-shuffleShR = \sh -> go (length (toList sh)) (toList sh) sh
- where
- go :: Int -> [Int] -> IShR n -> Gen (IShR n)
- go _ _ ZSR = return ZSR
- go nbag bag (_ :$: sh) = do
- idx <- Gen.int (Range.linear 0 (nbag - 1))
- let (dim, bag') = case splitAt idx bag of
- (pre, n : post) -> (n, pre ++ post)
- _ -> error "unreachable"
- (dim :$:) <$> go (nbag - 1) bag' sh
-
-genShR :: SNat n -> Gen (IShR n)
-genShR sn = do
- let n = fromSNat' sn
- targetSize <- Gen.int (Range.linear 0 100_000)
- let genDims :: SNat m -> Int -> Gen (IShR m)
- genDims SZ _ = return ZSR
- genDims (SS m) 0 = do
- dim <- Gen.int (Range.linear 0 20)
- dims <- genDims m 0
- return (dim :$: dims)
- genDims (SS m) tgt = do
- dim <- Gen.frequency [(20 * n, round <$> genLowBiased @Double (2.0, max 2.0 (sqrt (fromIntegral tgt))))
- ,(2 , return tgt)
- ,(4 , return 1)
- ,(1 , return 0)]
- dims <- genDims m (if dim == 0 then 0 else tgt `div` dim)
- return (dim :$: dims)
- dims <- genDims sn targetSize
- let dimsL = toList dims
- maxdim = maximum dimsL
- cap = binarySearch (`div` 2) 1 maxdim (\cap' -> product (min cap' <$> dimsL) <= targetSize)
- shuffleShR (min cap <$> dims)
-
-genStorables :: forall a. Storable a => Range Int -> (Word64 -> a) -> GenT IO (VS.Vector a)
-genStorables rng f = do
- n <- Gen.int rng
- seed <- Gen.resize 99 $ Gen.int Range.linearBounded
- let gen0 = Random.mkStdGen seed
- (bs, _) = Random.genByteString (8 * n) gen0
- let readW64 i = sum (zipWith (*) (iterate (*256) 1) [fromIntegral (bs `BS.index` (8 * i + j)) | j <- [0..7]])
- return $ VS.generate n (f . readW64)
-
-orSumOuter1 :: (OR.Unbox a, Num a) => SNat n -> OR.Array (n + 1) a -> OR.Array n a
-orSumOuter1 (sn@SNat :: SNat n) =
- let n = fromSNat' sn
- in OR.rerank @n @1 @0 (OR.scalar . OR.sumA) . OR.transpose ([1 .. n] ++ [0])
-
-rshTail :: ShR (n + 1) i -> ShR n i
-rshTail (_ :$: sh) = sh
-rshTail ZSR = error "unreachable"
main :: IO ()
main = defaultMain $
testGroup "Tests"
- [testGroup "C"
- [testGroup "sum"
- [testProperty "random nonempty" $ property $ genRank $ \outrank@(SNat @n) -> do
- -- Test nonempty _results_. The first dimension of the input is allowed to be 0, because then OR.rerank doesn't fail yet.
- let inrank = SNat @(n + 1)
- sh <- forAll $ genShR inrank
- -- traceM ("sh: " ++ show sh ++ " -> " ++ show (product sh))
- guard (all (> 0) (toList (rshTail sh))) -- only constrain the tail
- arr <- forAllT $ OR.fromVector @Double @(n + 1) (toList sh) <$>
- genStorables (Range.singleton (product sh))
- (\w -> fromIntegral w / fromIntegral (maxBound :: Word64))
- let rarr = rfromOrthotope inrank arr
- -- annotateShow rarr
- Refl <- return $ I.lemRankReplicate outrank
- let Ranked (I.M_Double (I.M_Primitive _ (X.XArray lhs))) = rsumOuter1 rarr
- let rhs = orSumOuter1 outrank arr
- -- annotateShow lhs
- -- annotateShow rhs
- lhs === rhs
-
- ,testProperty "random empty" $ property $ genRank $ \outrankm1@(SNat @nm1) -> do
- -- We only need to test shapes where the _result_ is empty; the rest is handled by 'random nonempty' above.
- outrank :: SNat n <- return $ SNat @(nm1 + 1)
- let inrank = SNat @(n + 1)
- sh <- forAll $ do
- shtt <- genShR outrankm1 -- nm1
- sht <- shuffleShR (0 :$: shtt) -- n
- n <- Gen.int (Range.linear 0 20)
- return (n :$: sht) -- n + 1
- guard (any (== 0) (toList (rshTail sh)))
- -- traceM ("sh: " ++ show sh ++ " -> " ++ show (product sh))
- let arr = OR.fromList @Double @(n + 1) (toList sh) []
- let rarr = rfromOrthotope inrank arr
- Refl <- return $ I.lemRankReplicate outrank
- let Ranked (I.M_Double (I.M_Primitive _ (X.XArray lhs))) = rsumOuter1 rarr
- OR.toList lhs === []
- ]
- ]
- ]
+ [Tests.C.tests]
diff --git a/test/Tests/C.hs b/test/Tests/C.hs
new file mode 100644
index 0000000..1041b2a
--- /dev/null
+++ b/test/Tests/C.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeAbstractions #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+-- {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
+module Tests.C where
+
+import Control.Monad
+import qualified Data.Array.RankedS as OR
+import Data.Foldable (toList)
+import Data.Type.Equality
+import Foreign
+import GHC.TypeLits
+
+import qualified Data.Array.Mixed as X
+import Data.Array.Nested
+import qualified Data.Array.Nested.Internal as I
+
+import Hedgehog
+import Hedgehog.Internal.Property (forAllT)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import Test.Tasty
+import Test.Tasty.Hedgehog
+
+-- import Debug.Trace
+
+import Gen
+import Util
+
+
+tests :: TestTree
+tests = testGroup "C"
+ [testGroup "sum"
+ [testProperty "random nonempty" $ property $ genRank $ \outrank@(SNat @n) -> do
+ -- Test nonempty _results_. The first dimension of the input is allowed to be 0, because then OR.rerank doesn't fail yet.
+ let inrank = SNat @(n + 1)
+ sh <- forAll $ genShR inrank
+ -- traceM ("sh: " ++ show sh ++ " -> " ++ show (product sh))
+ guard (all (> 0) (toList (rshTail sh))) -- only constrain the tail
+ arr <- forAllT $ OR.fromVector @Double @(n + 1) (toList sh) <$>
+ genStorables (Range.singleton (product sh))
+ (\w -> fromIntegral w / fromIntegral (maxBound :: Word64))
+ let rarr = rfromOrthotope inrank arr
+ -- annotateShow rarr
+ Refl <- return $ I.lemRankReplicate outrank
+ let Ranked (I.M_Double (I.M_Primitive _ (X.XArray lhs))) = rsumOuter1 rarr
+ let rhs = orSumOuter1 outrank arr
+ -- annotateShow lhs
+ -- annotateShow rhs
+ lhs === rhs
+
+ ,testProperty "random empty" $ property $ genRank $ \outrankm1@(SNat @nm1) -> do
+ -- We only need to test shapes where the _result_ is empty; the rest is handled by 'random nonempty' above.
+ outrank :: SNat n <- return $ SNat @(nm1 + 1)
+ let inrank = SNat @(n + 1)
+ sh <- forAll $ do
+ shtt <- genShR outrankm1 -- nm1
+ sht <- shuffleShR (0 :$: shtt) -- n
+ n <- Gen.int (Range.linear 0 20)
+ return (n :$: sht) -- n + 1
+ guard (any (== 0) (toList (rshTail sh)))
+ -- traceM ("sh: " ++ show sh ++ " -> " ++ show (product sh))
+ let arr = OR.fromList @Double @(n + 1) (toList sh) []
+ let rarr = rfromOrthotope inrank arr
+ Refl <- return $ I.lemRankReplicate outrank
+ let Ranked (I.M_Double (I.M_Primitive _ (X.XArray lhs))) = rsumOuter1 rarr
+ OR.toList lhs === []
+ ]
+ ]
diff --git a/test/Util.hs b/test/Util.hs
new file mode 100644
index 0000000..1249bf9
--- /dev/null
+++ b/test/Util.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
+module Util where
+
+import qualified Data.Array.RankedS as OR
+import GHC.TypeLits
+
+import Data.Array.Mixed (fromSNat')
+import Data.Array.Nested
+
+
+-- Returns highest value that satisfies the predicate, or `lo` if none does
+binarySearch :: (Num a, Eq a) => (a -> a) -> a -> a -> (a -> Bool) -> a
+binarySearch div2 = \lo hi f -> case (f lo, f hi) of
+ (False, _) -> lo
+ (_, True) -> hi
+ (_, _ ) -> go lo hi f
+ where
+ go lo hi f = -- invariant: f lo && not (f hi)
+ let mid = lo + div2 (hi - lo)
+ in if mid `elem` [lo, hi]
+ then mid
+ else if f mid then go mid hi f else go lo mid f
+
+orSumOuter1 :: (OR.Unbox a, Num a) => SNat n -> OR.Array (n + 1) a -> OR.Array n a
+orSumOuter1 (sn@SNat :: SNat n) =
+ let n = fromSNat' sn
+ in OR.rerank @n @1 @0 (OR.scalar . OR.sumA) . OR.transpose ([1 .. n] ++ [0])
+
+rshTail :: ShR (n + 1) i -> ShR n i
+rshTail (_ :$: sh) = sh
+rshTail ZSR = error "unreachable"
generated by cgit v1.2.3-70-g09d2 (git 2.51.0) at 2025-10-31 22:34:58 +0100