Commits

Anonymous committed 2c08c39

Use Data.Tagged instead of custom Phantom type

  • Participants
  • Parent commits 2e982d5

Comments (0)

Files changed (13)

File diffgeom.cabal

         , QuickCheck >= 2.0 && < 3.0
         , tasty >= 0.7
         , tasty-quickcheck >= 0.3
+        , tagged >= 0.7 && < 0.8
         , failure
 
 -- Documentation coverage reporting

File tests/DiffGeom/Classes/LieTest.hs

 
 -- |Enable generic testing
 import Test.Generic
+import Data.Tagged
 
 -- |'Monoid' tests
 propAssoc :: (Monoid a, TolSpace a) => (a, a, a) -> Property
 propIdRight g = property $ g <> mempty ~~ g
 
 -- |Summary of 'Monoid' tests
-monoidTests :: (Arbitrary a, Show a, TolSpace a, Monoid a) => [Phantom a TestTree]
+monoidTests :: (Arbitrary a, Show a, TolSpace a, Monoid a) => [Tagged a TestTree]
 monoidTests =
  [ genericTestPropertyTriple "<> is associative" propAssoc
  , genericTestProperty "mempty is left identity" propIdLeft
  ]
 
 allMonoidTests :: (Arbitrary a, Show a, TolSpace a, Monoid a)
-    => [Phantom a TestTree]
+    => [Tagged a TestTree]
 allMonoidTests =
     genericTestGroup "Monoid" monoidTests : allTolSpaceTests
 
 propInvRight g = property $ g <> invert g ~~ mempty
 
 -- |Summary of 'Group' tests
-groupTests :: (Arbitrary a, Show a, TolSpace a, Group a) => [Phantom a TestTree]
+groupTests :: (Arbitrary a, Show a, TolSpace a, Group a) => [Tagged a TestTree]
 groupTests =
  [ genericTestProperty "invert gives left inverse" propInvLeft
  , genericTestProperty "invert gives right inverse" propInvRight
  ]
 
 allGroupTests :: (Arbitrary a, Show a, TolSpace a, Group a)
-    => [Phantom a TestTree]
+    => [Tagged a TestTree]
 allGroupTests =
     genericTestGroup "Group" groupTests : allMonoidTests
 
 -- |'LieGroup' tests
 -- TODO: Lie group tests
-lieGroupTests :: (Arbitrary a, Show a, TolSpace a, LieGroup a) => [Phantom a TestTree]
+lieGroupTests :: (Arbitrary a, Show a, TolSpace a, LieGroup a) => [Tagged a TestTree]
 lieGroupTests = []
 
 -- |Summary of 'LieGroup' tests
 allLieGroupTests :: (Arbitrary a, Show a, TolSpace a, LieGroup a)
-    => [Phantom a TestTree]
+    => [Tagged a TestTree]
 allLieGroupTests =
     genericTestGroup "LieGroup" lieGroupTests : (allGroupTests ++ allSmoothTests)

File tests/DiffGeom/Classes/MetricTest.hs

 
 -- |Enable generic testing
 import Test.Generic
+import Data.Tagged
 
 -- |Tolerance for floating point comparisons in these tests
 tol = 1e-7
 
 -- |Summary of tests
 -- TODO: Print tolerance in test names
-metricTests :: (Arbitrary a, Show a, Metric a) => [Phantom a TestTree]
+metricTests :: (Arbitrary a, Show a, Metric a) => [Tagged a TestTree]
 metricTests =
  [ genericTestPropertyPair "distSquared = dist^2" propDistSquared
  , genericTestPropertyPair "Distance is symmetric" propMetricSym
  , genericTestPropertyTriple "Triangle inequality" propTriangleIneq
  ]
 
-allMetricTests :: (Arbitrary a, Show a, Metric a) => [Phantom a TestTree]
+allMetricTests :: (Arbitrary a, Show a, Metric a) => [Tagged a TestTree]
 allMetricTests = 
     genericTestGroup "Metric" metricTests : allTolSpaceTests

File tests/DiffGeom/Classes/RiemTest.hs

 
 -- |Enable generic testing
 import Test.Generic
+import Data.Tagged
 
 -- |Should always be able to log(x,x), and result should be zero
 propLogZero :: (Riem a) => a -> Property
     Show a,
     Show (TangentType a),
     Show (CoTangentType a),
-    Riem a) => [Phantom a TestTree]
+    Riem a) => [Tagged a TestTree]
 riemTests =
  [ genericTestProperty "Log of same point is zero" propLogZero
  , genericTestPropertyPair "Distance compatible with log" propDistLog
     Show (TangentType a),
     Show (CoTangentType a),
     Riem a)
-    => [Phantom a TestTree]
+    => [Tagged a TestTree]
 allRiemTests =
     genericTestGroup "Riem" riemTests : (allSmoothTests ++ allMetricTests)

File tests/DiffGeom/Classes/SmoothTest.hs

 
 -- |Enable generic testing
 import Test.Generic
+import Data.Tagged
 
 -- TODO: Put the fiber bundle and vector bundle tests here for TangentType and
 -- CoTangentType
 
 -- |Summary of tests
-smoothTests :: (Arbitrary a, Show a, Smooth a) => [Phantom a TestTree]
+smoothTests :: (Arbitrary a, Show a, Smooth a) => [Tagged a TestTree]
 smoothTests = [ ]
 
 allSmoothTests :: (Arbitrary a, Show a, Smooth a)
-    => [Phantom a TestTree]
+    => [Tagged a TestTree]
 allSmoothTests =
     genericTestGroup "Smooth" smoothTests : allTolSpaceTests

File tests/DiffGeom/Classes/TolSpaceTest.hs

 
 -- |Enable generic testing
 import Test.Generic
+import Data.Tagged
 
 -- |Test the axioms for a tolerance space
 propTolReflexiveZero :: (TolSpace a) => a -> Property
 propTolSymmetric (x,y) = property $ (x ~~ y) == (y ~~ x)
 
 -- |Summary of tests
-tolSpaceTests :: (Arbitrary a, Show a, TolSpace a) => [Phantom a TestTree]
+tolSpaceTests :: (Arbitrary a, Show a, TolSpace a) => [Tagged a TestTree]
 tolSpaceTests =
  [ genericTestProperty "x ~~ x always" propTolReflexiveZero
  , genericTestPropertyPair "~~ is symmetric" propTolSymmetric
  ]
 
-allTolSpaceTests :: (Arbitrary a, Show a, TolSpace a) => [Phantom a TestTree]
+allTolSpaceTests :: (Arbitrary a, Show a, TolSpace a) => [Tagged a TestTree]
 allTolSpaceTests = [genericTestGroup "TolSpace" tolSpaceTests]

File tests/DiffGeom/Classes/VectorSpaceTest.hs

 
 -- |Enable generic testing
 import Test.Generic
+import Data.Tagged
 
 {- |Test the axioms of a 'RealVectorSpace'.
 Note that we require a 'TolSpace' instance so that we can test equality reliably
 
 -- |Summary of 'VectorSpace' tests
 realVectorSpaceTests :: (Arbitrary a, Show a, RealVectorSpace a, TolSpace a)
-    => [Phantom a TestTree]
+    => [Tagged a TestTree]
 realVectorSpaceTests =
     [ genericTestPropertyPair "Addition is commutative" propPlusCommutes
     , genericTestPropertyTriple "Addition is associative" propPlusAssoc
     ]
 
 allRealVectorSpaceTests :: (Arbitrary a, Show a, RealVectorSpace a, TolSpace a)
-    => [Phantom a TestTree]
+    => [Tagged a TestTree]
 allRealVectorSpaceTests = 
     genericTestGroup "RealVectorSpace" realVectorSpaceTests : allTolSpaceTests
 
 
 -- |Summary of 'RealNormedSpace' tests
 realNormedSpaceTests :: (Arbitrary a, Show a, RealNormedSpace a, TolSpace a)
-    => [Phantom a TestTree]
+    => [Tagged a TestTree]
 realNormedSpaceTests = 
     [ genericTestProperty "Norm is non-negative" propNonNeg
     , genericTestPropertyDouble "Norm is 1-homogeneous" propHomog
     ]
 
 allRealNormedSpaceTests :: (Arbitrary a, Show a, RealNormedSpace a, TolSpace a)
-    => [Phantom a TestTree]
+    => [Tagged a TestTree]
 allRealNormedSpaceTests = 
     genericTestGroup "RealNormedSpace" realNormedSpaceTests : allRealVectorSpaceTests
 
 
 -- |Summary of 'RealInnerProductSpace' tests
 realInnerProductSpaceTests :: (Arbitrary a, Show a, TolSpace a,
-    RealInnerProductSpace a) => [Phantom a TestTree]
+    RealInnerProductSpace a) => [Tagged a TestTree]
 realInnerProductSpaceTests = 
     [ genericTestPropertyPair "Inner product is symmetric" propIPSym
     , genericTestPropertyPairDouble "Inner product is linear" propIPLinear
     ]
 
 allRealInnerProductSpaceTests :: (Arbitrary a, Show a, RealInnerProductSpace a, TolSpace a)
-    => [Phantom a TestTree]
+    => [Tagged a TestTree]
 allRealInnerProductSpaceTests = 
     genericTestGroup "RealInnerProductSpace" realInnerProductSpaceTests : allRealNormedSpaceTests
 
 dualPairTests :: (Arbitrary a, Show a, TolSpace a,
                   Arbitrary b, Show b, TolSpace b,
                   DualPair a b)
-    => [Phantom (a, b) TestTree]
+    => [Tagged (a, b) TestTree]
 dualPairTests =
     [
     ]

File tests/DiffGeom/Spaces/QuaternionsTest.hs

 import DiffGeom.Classes.RiemTest
 
 import Test.Generic
+import Data.Tagged
 
 instance Arbitrary Quatern where
     arbitrary = do
 
 allQuaternTests = testGroup "Quatern" $ quaternTests : [cgp]
   where
-    cgp = testGroup "Classes" $ map runPhantom (t :: [Phantom Quatern TestTree])
+    cgp = testGroup "Classes" $ map unTagged (t :: [Tagged Quatern TestTree])
     t = allMonoidTests ++ allRealInnerProductSpaceTests

File tests/DiffGeom/Spaces/RealTest.hs

 import DiffGeom.Algorithms.Frechet
 
 import Test.Generic
+import Data.Tagged
 
 -- |First, make DiffReal an instance of Arbitrary, so we can use QuickCheck
 instance Arbitrary DiffReal where
 allDiffRealTests :: TestTree
 allDiffRealTests = testGroup "DiffReal" $ realTests : [cgp]
   where
-    cgp = testGroup "Classes" $ map runPhantom (t :: [Phantom DiffReal TestTree])
+    cgp = testGroup "Classes" $ map unTagged (t :: [Tagged DiffReal TestTree])
     t = allRealInnerProductSpaceTests ++ allRiemTests

File tests/DiffGeom/Spaces/RotationsTest.hs

 import DiffGeom.Classes.RiemTest
 
 import Test.Generic
+import Data.Tagged
 
 instance Arbitrary Rot3 where
     arbitrary = do
 allRot3Tests :: TestTree
 allRot3Tests = testGroup "Rot3" $ rot3Tests : [cgp]
   where
-    cgp = testGroup "Classes" $ map runPhantom (t :: [Phantom Rot3 TestTree])
+    cgp = testGroup "Classes" $ map unTagged (t :: [Tagged Rot3 TestTree])
     t = allGroupTests

File tests/DiffGeom/Spaces/SphereTest.hs

 import DiffGeom.Spaces.Sphere
 
 import Test.Generic
+import Data.Tagged
 
 instance Arbitrary SpherePt where
     arbitrary = do
 
 allSphereTests = testGroup "Sphere" $ sphereTests : [cgp]
   where
-    cgp = testGroup "Classes" $ map runPhantom (t :: [Phantom SpherePt TestTree])
+    cgp = testGroup "Classes" $ map unTagged (t :: [Tagged SpherePt TestTree])
     t = allRiemTests

File tests/DiffGeom/Spaces/Vec3Test.hs

 import DiffGeom.Spaces.Vec3
 
 import Test.Generic
+import Data.Tagged
 
 instance Arbitrary Vec3 where
     arbitrary = do
 allVec3Tests :: TestTree
 allVec3Tests = testGroup "Vec3" $ vec3Tests : [cgp]
   where
-    cgp = testGroup "Classes" $ map runPhantom (t :: [Phantom Vec3 TestTree])
+    cgp = testGroup "Classes" $ map unTagged (t :: [Tagged Vec3 TestTree])
     t = allRealInnerProductSpaceTests

File tests/Test/Generic.hs

 import DiffGeom.Classes.Smooth
 import DiffGeom.Classes.Fiber
 
--- |Now use a phantom type parameter to force testing on various spaces
-newtype Phantom a b = P { runPhantom :: b }
+import Data.Tagged
 
 -- |Take a group of tests and perform them together, but keep phantom type
-genericTestGroup :: TestName -> [Phantom a TestTree] -> Phantom a TestTree
-genericTestGroup x ts = P $ testGroup x $ map runPhantom ts
+genericTestGroup :: TestName -> [Tagged a TestTree] -> Tagged a TestTree
+genericTestGroup x ts = Tagged $ testGroup x $ map unTagged ts
 
 -- |Test a quickcheck property generically using :9
-genericTestProperty :: (Arbitrary a, Show a) => TestName -> (a -> Property) -> Phantom a TestTree
-genericTestProperty x p = P $ testProperty x p
+genericTestProperty :: (Arbitrary a, Show a) => TestName -> (a -> Property) -> Tagged a TestTree
+genericTestProperty x p = Tagged $ testProperty x p
 
-genericTestPropertyPair :: (Arbitrary a, Show a) => TestName -> ((a,a) -> Property) -> Phantom a TestTree
-genericTestPropertyPair x p = P $ testProperty x p
+genericTestPropertyPair :: (Arbitrary a, Show a) => TestName -> ((a,a) -> Property) -> Tagged a TestTree
+genericTestPropertyPair x p = Tagged $ testProperty x p
 
-genericTestPropertyTriple :: (Arbitrary a, Show a) => TestName -> ((a,a,a) -> Property) -> Phantom a TestTree
-genericTestPropertyTriple x p = P $ testProperty x p
+genericTestPropertyTriple :: (Arbitrary a, Show a) => TestName -> ((a,a,a) -> Property) -> Tagged a TestTree
+genericTestPropertyTriple x p = Tagged $ testProperty x p
 
 -- |Insert a TangentType into a test
-genericTestPropertyTangent :: (Arbitrary (TangentType a), Show (TangentType a)) => TestName -> (TangentType a -> Property) -> Phantom a TestTree
-genericTestPropertyTangent x p = P $ testProperty x p
+genericTestPropertyTangent :: (Arbitrary (TangentType a), Show (TangentType a)) => TestName -> (TangentType a -> Property) -> Tagged a TestTree
+genericTestPropertyTangent x p = Tagged $ testProperty x p
 -- |Insert a CoTangentType into a test
-genericTestPropertyCoTangent :: (Arbitrary (CoTangentType a), Show (CoTangentType a)) => TestName -> (CoTangentType a -> Property) -> Phantom a TestTree
-genericTestPropertyCoTangent x p = P $ testProperty x p
+genericTestPropertyCoTangent :: (Arbitrary (CoTangentType a), Show (CoTangentType a)) => TestName -> (CoTangentType a -> Property) -> Tagged a TestTree
+genericTestPropertyCoTangent x p = Tagged $ testProperty x p
 -- |Insert a BaseType from some FiberBundle into a test
-genericTestPropertyBaseType :: (Arbitrary (BaseType a), Show (BaseType a)) => TestName -> (BaseType a -> Property) -> Phantom a TestTree
-genericTestPropertyBaseType x p = P $ testProperty x p
+genericTestPropertyBaseType :: (Arbitrary (BaseType a), Show (BaseType a)) => TestName -> (BaseType a -> Property) -> Tagged a TestTree
+genericTestPropertyBaseType x p = Tagged $ testProperty x p
 
 -- |Also throw in an arbitrary Double
-genericTestPropertyDouble :: (Arbitrary a, Show a) => TestName -> ((a, Double) -> Property) -> Phantom a TestTree
-genericTestPropertyDouble x p = P $ testProperty x p
+genericTestPropertyDouble :: (Arbitrary a, Show a) => TestName -> ((a, Double) -> Property) -> Tagged a TestTree
+genericTestPropertyDouble x p = Tagged $ testProperty x p
 -- |Throw in a pair of doubles
-genericTestPropertyDoublePair :: (Arbitrary a, Show a) => TestName -> ((a, Double, Double) -> Property) -> Phantom a TestTree
-genericTestPropertyDoublePair x p = P $ testProperty x p
+genericTestPropertyDoublePair :: (Arbitrary a, Show a) => TestName -> ((a, Double, Double) -> Property) -> Tagged a TestTree
+genericTestPropertyDoublePair x p = Tagged $ testProperty x p
 -- |Need two a's and a Double
-genericTestPropertyPairDouble :: (Arbitrary a, Show a) => TestName -> ((a, a, Double) -> Property) -> Phantom a TestTree
-genericTestPropertyPairDouble x p = P $ testProperty x p
+genericTestPropertyPairDouble :: (Arbitrary a, Show a) => TestName -> ((a, a, Double) -> Property) -> Tagged a TestTree
+genericTestPropertyPairDouble x p = Tagged $ testProperty x p