Merge branch 'develop-core-tests-coverage'. Close #502.

ivanperez-keera · ivanperez-keera · commit 3725ca21ada9 · 2024-03-07T23:58:11.000-08:00
**Description**

The test coverage of `copilot-core` is currently reported at 25% by
Hackage. This is very low.

Although there are exceptions to what we can test (record fields of
existential types) or should tests (proxies, automatically generated
constructors and accessor functions), the coverage of our tests should
be higher and anything that is not tested should be documented.

**Type**

- Maintenance: Increase coverage of tests.

**Additional context**

None.

**Requester**

- Ivan Perez

**Method to check presence of bug**

Not applicable (not a bug).

**Expected result**

All top-level functions that are not automatically generated by the
compiler are tested, except where testing them is not possible or for
code that is automatically generated (constructors, record accessor
functions). Anything not tested is documented.

**Solution implemented**

Add tests for all definitions in `Copilot.Core.Type` and
`Copilot.Core.Type.Array`, except record accessor functions.

Running tests with coverage enabled achieves coverage of 97% for
top-level definitions (37 out of 38 definitions). The one not tested is
uTypeType, which cannot be tested due to being part of an existential
type (it's necessity is being discussed in issue 484). The modules
Copilot.Core.Operators and Copilot.Core.Spec and Copilot.Core.Expr only
contain datatype definitions, so they do not need to be tested.

**Further notes**

None.
diff --git a/copilot-core/CHANGELOG b/copilot-core/CHANGELOG
@@ -1,6 +1,7 @@
 2024-03-07
         * Remove deprecated functions in Copilot.Core.Type and
           Copilot.Core.Type.Array. (#500)
+        * Increase test coverage. (#502)
 
 2024-01-07
         * Version bump (3.18.1). (#493)
diff --git a/copilot-core/tests/Test/Copilot/Core/Type.hs b/copilot-core/tests/Test/Copilot/Core/Type.hs
@@ -1,14 +1,24 @@
+{-# LANGUAGE DataKinds #-}
 -- | Test copilot-core:Copilot.Core.Type.
 module Test.Copilot.Core.Type where
 
 -- External imports
+import Data.Int                             (Int16, Int32, Int64, Int8)
+import Data.Maybe                           (isJust)
+import Data.Type.Equality                   (testEquality)
+import Data.Word                            (Word16, Word32, Word64, Word8)
 import Test.Framework                       (Test, testGroup)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.QuickCheck                      (Gen, Property, elements,
-                                             forAllBlind, shuffle, (==>))
+import Test.QuickCheck                      (Gen, Property, arbitrary, elements,
+                                             expectFailure, forAll, forAllBlind,
+                                             property, shuffle, (==>))
 
 -- Internal imports: library modules being tested
-import Copilot.Core.Type (SimpleType (..), Type(..), simpleType)
+import Copilot.Core.Type       (Field (..), SimpleType (..), Struct (..),
+                                Type (..), Typed, UType (..), Value (..),
+                                accessorName, fieldName, simpleType, typeLength,
+                                typeOf, typeSize)
+import Copilot.Core.Type.Array (Array)
 
 -- | All unit tests for copilot-core:Copilot.Core.Type.
 tests :: Test.Framework.Test
@@ -24,6 +34,38 @@ tests =
         testSimpleTypesEqualityTransitive
     , testProperty "uniqueness of equality of simple types"
         testSimpleTypesEqualityUniqueness
+    , testProperty "typeLength matches array size for 1-dimensional arrays"
+        testTypeLength1
+    , testProperty "typeLength matches array size for 2-dimensional arrays"
+        testTypeLength2
+    , testProperty "typeSize matches full array size for 1-dimensional arrays"
+        testTypeSize1
+    , testProperty "typeSize matches full array size for 2-dimensional arrays"
+        testTypeSize2
+    , testProperty "equality of types"
+        testUTypesEqualitySymmetric
+    , testProperty "equality of utype"
+        testUTypesEq
+    , testProperty "inequality of utype"
+        testUTypesInequality
+    , testProperty "inequality of utype via typeOf"
+        testUTypesTypeOfInequality
+    , testProperty "fieldName matches field name (positive)"
+        testFieldNameOk
+    , testProperty "fieldName matches field name (negative)"
+        testFieldNameFail
+    , testProperty "Show field name"
+        testShowField
+    , testProperty "Show struct"
+        testShowStruct
+    , testProperty "accessorName matches field name (positive)"
+        testAccessorNameOk
+    , testProperty "accessorName matches field name (negative)"
+        testAccessorNameFail
+    , testProperty "typeName matches struct type name (positive)"
+        testTypeNameOk
+    , testProperty "typeName matches struct type name (negative)"
+        testTypeNameFail
     ]
 
 -- | Test that the function simpleTypes preserves inequality, that is, it
@@ -53,6 +95,8 @@ testSimpleTypesInequality = forAllBlind twoDiffTypes $ \(t1, t2) ->
                 , simpleType Word64
                 , simpleType Float
                 , simpleType Double
+                , simpleType (Array Int8 :: Type (Array 3 Int8))
+                , simpleType (Struct (S (Field 0)))
                 ]
 
 -- | Test that the equality relation for simple types is reflexive.
@@ -97,4 +141,199 @@ simpleTypes =
   , SFloat
   , SDouble
   , SStruct
+  , SArray Int8
+  , SArray Int16
   ]
+
+-- | Test that the length of an array is as expected.
+testTypeLength1 :: Property
+testTypeLength1 = property $ typeLength a == 3
+  where
+    a :: Type (Array 3 Int8)
+    a = Array Int8
+
+-- | Test that the length of an multi-dimensional array is as expected.
+testTypeLength2 :: Property
+testTypeLength2 = property $ typeLength a == 3
+  where
+    a :: Type (Array 3 (Array 12 Int8))
+    a = Array (Array Int8)
+
+-- | Test that the size of an array is as expected.
+testTypeSize1 :: Property
+testTypeSize1 = property $ typeLength a == 3
+  where
+    a :: Type (Array 3 Int8)
+    a = Array Int8
+
+-- | Test that the size of a multi-dimensional array is as expected (flattens
+-- the array).
+testTypeSize2 :: Property
+testTypeSize2 = property $ typeSize a == 36
+  where
+    a :: Type (Array 3 (Array 12 Int8))
+    a = Array (Array Int8)
+
+-- | Test that equality is symmetric for UTypes via testEquality.
+testUTypesEqualitySymmetric :: Property
+testUTypesEqualitySymmetric =
+  forAllBlind (elements utypes) $ \(UType t1) -> isJust (testEquality t1 t1)
+
+-- | Test that testEquality implies equality for UTypes.
+testUTypesEq :: Property
+testUTypesEq =
+  forAllBlind (elements utypes) $ \t@(UType t1) -> isJust (testEquality t1 t1) ==> t == t
+
+-- | Test that any two different UTypes are not equal.
+--
+-- This function pre-selects two UTypes from a list of different UTypes, which
+-- guarantees that they will be different.
+testUTypesInequality :: Property
+testUTypesInequality = forAllBlind twoDiffTypes $ \(t1, t2) ->
+    t1 /= t2
+  where
+    twoDiffTypes :: Gen (UType, UType)
+    twoDiffTypes = do
+      shuffled <- shuffle utypes
+      case shuffled of
+        (t1:t2:_) -> return (t1, t2)
+        _         -> return (UType Bool, UType Bool)
+
+-- | Different UTypes.
+utypes :: [UType]
+utypes =
+    [ UType Bool
+    , UType Int8
+    , UType Int16
+    , UType Int32
+    , UType Int64
+    , UType Word8
+    , UType Word16
+    , UType Word32
+    , UType Word64
+    , UType Float
+    , UType Double
+    , UType a
+    , UType b
+    , UType c
+    ]
+  where
+    a :: Type (Array 3 Int8)
+    a = Array Int8
+
+    b :: Type (Array 4 Int8)
+    b = Array Int8
+
+    c :: Type S
+    c = Struct (S (Field 0))
+
+-- | Test that any two different UTypes are not equal.
+--
+-- This function pre-selects two UTypes from a list of different UTypes built
+-- via the function typeOf, which guarantees that they will be different.
+testUTypesTypeOfInequality :: Property
+testUTypesTypeOfInequality = forAllBlind twoDiffTypes $ \(t1@(UType t1'), t2@(UType t2')) ->
+    -- The seqs are important: otherwise, the coverage goes down drastically
+    -- because the typeOf function is not really executed.
+    t1' `seq` t2' `seq` t1 /= t2
+  where
+    twoDiffTypes :: Gen (UType, UType)
+    twoDiffTypes = do
+      shuffled <- shuffle uTypesTypeOf
+      case shuffled of
+        (t1:t2:_) -> t1 `seq` t2 `seq` return (t1, t2)
+        _         -> return (UType Bool, UType Bool)
+
+-- | Different UTypes, produced by using the function typeOf.
+uTypesTypeOf :: [UType]
+uTypesTypeOf =
+    [ UType (typeOf :: Type Bool)
+    , UType (typeOf :: Type Int8)
+    , UType (typeOf :: Type Int16)
+    , UType (typeOf :: Type Int32)
+    , UType (typeOf :: Type Int64)
+    , UType (typeOf :: Type Word8)
+    , UType (typeOf :: Type Word16)
+    , UType (typeOf :: Type Word32)
+    , UType (typeOf :: Type Word64)
+    , UType (typeOf :: Type Float)
+    , UType (typeOf :: Type Double)
+    , UType (typeOf :: Type (Array 3 Int8))
+    , UType (typeOf :: Type S)
+    ]
+
+-- | Test the fieldName function (should succeed).
+testFieldNameOk :: Property
+testFieldNameOk = forAll arbitrary $ \k ->
+    fieldName (s1 (S (Field k))) == s1FieldName
+  where
+    s1FieldName = "field"
+
+-- | Test the fieldName function (should fail).
+testFieldNameFail :: Property
+testFieldNameFail = expectFailure $ property $
+    fieldName (s1 sampleS) == s1FieldName
+  where
+    sampleS     = S (Field 0)
+    s1FieldName = "Field"
+
+-- | Test showing a field of a struct.
+testShowField :: Property
+testShowField = forAll arbitrary $ \k ->
+  show (s1 (S (Field k))) == ("field:" ++ show k)
+
+-- | Test showing a struct.
+testShowStruct :: Property
+testShowStruct = forAll arbitrary $ \k ->
+  show (S (Field k)) == "<field:" ++ show k ++ ">"
+
+-- | Test the accessorName of a field of a struct (should succeed).
+testAccessorNameOk :: Property
+testAccessorNameOk = property $
+    accessorName s1 == s1FieldName
+  where
+    s1FieldName = "field"
+
+-- | Test the accessorName of a field of a struct (should fail).
+testAccessorNameFail :: Property
+testAccessorNameFail = expectFailure $ property $
+    accessorName s1 == s1FieldName
+  where
+    s1FieldName = "Field"
+
+-- | Test the typeName of a struct (should succeed).
+testTypeNameOk :: Property
+testTypeNameOk = property $
+     typeName sampleS == s1TypeName
+
+  where
+
+    sampleS :: S
+    sampleS = S (Field 0)
+
+    s1TypeName :: String
+    s1TypeName = "S"
+
+-- | Test the typeName of a struct (should fail).
+testTypeNameFail :: Property
+testTypeNameFail = expectFailure $ property $
+     typeName sampleS == s1TypeName
+
+  where
+
+    sampleS :: S
+    sampleS = S (Field 0)
+
+    s1TypeName :: String
+    s1TypeName = "s"
+
+-- | Auxiliary struct defined for testing purposes.
+data S = S { s1 :: Field "field" Int8 }
+
+instance Struct S where
+  typeName _ = "S"
+
+  toValues s = [ Value Int8 (s1 s) ]
+
+instance Typed S where
+  typeOf = Struct (S (Field 0))
diff --git a/copilot-core/tests/Test/Copilot/Core/Type/Array.hs b/copilot-core/tests/Test/Copilot/Core/Type/Array.hs
@@ -9,8 +9,9 @@ import Data.Proxy                           (Proxy (..))
 import GHC.TypeNats                         (KnownNat, natVal)
 import Test.Framework                       (Test, testGroup)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.QuickCheck                      (Gen, Property, arbitrary, forAll,
-                                             vectorOf)
+import Test.QuickCheck                      (Gen, Property, arbitrary,
+                                             expectFailure, forAll, property,
+                                             vector, vectorOf)
 
 -- Internal imports: library modules being tested
 import Copilot.Core.Type.Array (Array, array, arrayElems)
@@ -25,6 +26,10 @@ tests =
         (testArrayElemsLeft (Proxy :: Proxy 5))
     , testProperty "arrayElems . array (identity; 200)"
         (testArrayElemsLeft (Proxy :: Proxy 200))
+    , testProperty "array of incorrect length"
+        testArrayElemsFail
+    , testProperty "Show for arrays"
+        testShowArray
     ]
 
 -- * Individual tests
@@ -43,3 +48,15 @@ testArrayElemsLeft len =
     -- Generator for lists of Int64 of known length.
     xsInt64 :: Gen [Int64]
     xsInt64 = vectorOf (fromIntegral (natVal len)) arbitrary
+
+-- | Test that arrays cannot be properly evaluated if their length does not
+-- match their type.
+testArrayElemsFail :: Property
+testArrayElemsFail = expectFailure $ forAll (vector 3) $ \l ->
+  let v = array l :: Array 4 Int64
+  in arrayElems v == l
+
+-- | Test show for arrays.
+testShowArray :: Property
+testShowArray = forAll (vector 3) $ \l -> property $
+  show (array l :: Array 3 Int64) == show (l :: [Int64])
