From d8e2fcf4ea979fe272db48fc2889f4c2636c50d7 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Tue, 28 May 2024 21:46:34 +0200
Subject: Reorganise test files

---
 test/Tests/C.hs | 73 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 73 insertions(+)
 create mode 100644 test/Tests/C.hs

(limited to 'test/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 === []
+    ]
+  ]
-- 
cgit v1.2.3-70-g09d2