Merge branch 'develop-copilot-core-coverage'. Close #555.

**Description**

The test coverage of `copilot-core` is currently reported at 75% by
Hackage.

Although there are exceptions to what we can test (record fields of
existential types) or should test (proxies, automatically generated
constructors and accessor functions), the coverage of our tests should
include very top level definition and expression that can be tested
without having to modify the implementation of `copilot-core` itself.

**Type**

- Management: Increase coverage of tests.

**Additional context**

There are limitations to what we can test, or how we can instruct HPC to
ignore certain symbols. At present, we don't have a simply way of
modifying `copilot-core`'s cabal package to tick specific symbols or
expressions. Future improvements to HPC may make this possible.

**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, when
code is automatically generated (constructors, record accessor
functions), or when values do not need to be fully evaluated (e.g.,
Proxy's, `()`).

**Solution implemented**

Add tests for all definitions in `copilot-core` that are not
automatically generated and can be tested without having to modify the
implementation of the library (e.g., to force WHNF/NF in lazily
evaluated values like Proxy).

Running the code coverage in GHC produces a report indicating that 35/36
top-level definitions in Copilot.Core.Type and 4/4 in
Copilot.Core.Type.Array. The top-level definition not covered in
Copilot.Core.Type is deprecated and will be removed in a future release.
There's full alternative coverage for both modules (100%), and the
expressions not covered are Proxys, and arguments not evaluated due to
laziness.

**Further notes**

None.

copilot-core/CHANGELOG

@@ -1,5 +1,6 @@
-2024-11-15
+2024-12-29
         * Deprecate fields of Copilot.Core.Expr.UExpr. (#565)
+        * Increase test coverage. (#555)
 
 2024-11-07
         * Version bump (4.1). (#561)

copilot-core/tests/Test/Copilot/Core/Type.hs

@@ -1,12 +1,19 @@
-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
 -- | 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.Proxy                           (Proxy (..))
+import Data.Type.Equality                   (TestEquality (..), testEquality,
+                                             (:~:) (..))
 import Data.Word                            (Word16, Word32, Word64, Word8)
+import GHC.TypeLits                         (sameSymbol)
+import Prelude                              as P
 import Test.Framework                       (Test, testGroup)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
 import Test.QuickCheck                      (Gen, Property, arbitrary, elements,
@@ -50,6 +57,8 @@ tests =
         testUTypesInequality
     , testProperty "inequality of utype via typeOf"
         testUTypesTypeOfInequality
+    , testProperty "inequality of different types"
+        testTypesInequality
     , testProperty "fieldName matches field name (positive)"
         testFieldNameOk
     , testProperty "fieldName matches field name (negative)"
@@ -58,6 +67,10 @@ tests =
         testShowField
     , testProperty "Show struct"
         testShowStruct
+    , testProperty "Update struct"
+        testUpdateStruct
+    , testProperty "Update struct"
+        testUpdateStructFail
     , testProperty "accessorName matches field name (positive)"
         testAccessorNameOk
     , testProperty "accessorName matches field name (negative)"
@@ -96,7 +109,7 @@ testSimpleTypesInequality = forAllBlind twoDiffTypes $ \(t1, t2) ->
                 , simpleType Float
                 , simpleType Double
                 , simpleType (Array Int8 :: Type (Array 3 Int8))
-                , simpleType (Struct (S (Field 0)))
+                , simpleType (Struct (S (Field 0) (Field 0)))
                 ]
 
 -- | Test that the equality relation for simple types is reflexive.
@@ -177,12 +190,12 @@ testTypeSize2 = property $ typeSize a == 36
 -- | Test that equality is symmetric for UTypes via testEquality.
 testUTypesEqualitySymmetric :: Property
 testUTypesEqualitySymmetric =
-  forAllBlind (elements utypes) $ \(UType t1) -> isJust (testEquality t1 t1)
+  forAllBlind (elements utypes) $ \(UType t1) -> testEquality t1 t1 == Just Refl
 
 -- | Test that testEquality implies equality for UTypes.
 testUTypesEq :: Property
 testUTypesEq =
-  forAllBlind (elements utypes) $ \t@(UType t1) -> isJust (testEquality t1 t1) ==> t == t
+  forAllBlind (elements utypes) $ \t@(UType t1) -> (testEquality t1 t1 == Just Refl) ==> t == t
 
 -- | Test that any two different UTypes are not equal.
 --
@@ -199,6 +212,21 @@ testUTypesInequality = forAllBlind twoDiffTypes $ \(t1, t2) ->
         (t1:t2:_) -> return (t1, t2)
         _         -> return (UType Bool, UType Bool)
 
+-- | Test that any two different Types are not equal.
+--
+-- This function pre-selects two Types from a list of different UTypes, which
+-- guarantees that they will be different.
+testTypesInequality :: Property
+testTypesInequality = forAllBlind twoDiffTypes $ \(UType t1, UType t2) ->
+    testEquality t1 t2 == Nothing
+  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 =
@@ -213,19 +241,43 @@ utypes =
     , UType Word64
     , UType Float
     , UType Double
-    , UType a
-    , UType b
+    , UType a1
+    , UType a2
+    , UType a3
+    , UType a4
+    , UType b1
+    , UType b2
+    , UType b3
+    , UType b4
     , UType c
     ]
   where
-    a :: Type (Array 3 Int8)
-    a = Array Int8
+    a1 :: Type (Array 3 Int8)
+    a1 = Array Int8
+
+    a2 :: Type (Array 4 Int8)
+    a2 = Array Int8
+
+    a3 :: Type (Array 5 Int8)
+    a3 = Array Int8
+
+    a4 :: Type (Array 6 Int8)
+    a4 = Array Int8
 
-    b :: Type (Array 4 Int8)
-    b = Array Int8
+    b1 :: Type (Array 3 Int16)
+    b1 = Array Int16
+
+    b2 :: Type (Array 4 Int16)
+    b2 = Array Int16
+
+    b3 :: Type (Array 5 Int16)
+    b3 = Array Int16
+
+    b4 :: Type (Array 6 Int16)
+    b4 = Array Int16
 
     c :: Type S
-    c = Struct (S (Field 0))
+    c = Struct (S (Field 0) (Field 0))
 
 -- | Test that any two different UTypes are not equal.
 --
@@ -259,47 +311,86 @@ uTypesTypeOf =
     , UType (typeOf :: Type Float)
     , UType (typeOf :: Type Double)
     , UType (typeOf :: Type (Array 3 Int8))
+    , UType (typeOf :: Type (Array 3 Int16))
+    , UType (typeOf :: Type (Array 3 Int32))
+    , UType (typeOf :: Type (Array 3 Int64))
+    , UType (typeOf :: Type (Array 3 Word8))
+    , UType (typeOf :: Type (Array 3 Word16))
+    , UType (typeOf :: Type (Array 3 Word32))
+    , UType (typeOf :: Type (Array 3 Word64))
+    , UType (typeOf :: Type (Array 3 Double))
+    , UType (typeOf :: Type (Array 3 Float))
     , UType (typeOf :: Type S)
     ]
 
 -- | Test the fieldName function (should succeed).
 testFieldNameOk :: Property
-testFieldNameOk = forAll arbitrary $ \k ->
-    fieldName (s1 (S (Field k))) == s1FieldName
+testFieldNameOk = forAll arbitrary $ \k1 ->
+                  forAll arbitrary $ \k2 ->
+    fieldName (s1 (S (Field k1) (Field k2))) == s1FieldName
   where
-    s1FieldName = "field"
+    s1FieldName = "field1"
 
 -- | Test the fieldName function (should fail).
 testFieldNameFail :: Property
 testFieldNameFail = expectFailure $ property $
     fieldName (s1 sampleS) == s1FieldName
   where
-    sampleS     = S (Field 0)
+    sampleS     = S (Field 0) (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)
+  show (s1 (S (Field k) (Field 0))) == ("field1:" ++ show k)
 
 -- | Test showing a struct.
 testShowStruct :: Property
-testShowStruct = forAll arbitrary $ \k ->
-  show (S (Field k)) == "<field:" ++ show k ++ ">"
+testShowStruct = forAll arbitrary $ \k1 ->
+                 forAll arbitrary $ \k2 ->
+  show (S (Field k1) (Field k2)) == "<field1:" ++ show k1 ++ ",field2:" ++ show k2 ++ ">"
+
+-- | Test showing a struct.
+testUpdateStruct :: Property
+testUpdateStruct =
+   forAll arbitrary $ \k1 ->
+   forAll arbitrary $ \k2 ->
+     let f :: Field "field1" Int8
+         f = Field k2
+         v :: Value Int8
+         v = Value Int8 f
+     in unField (s1 (updateField (S (Field k1) (Field 0)) v)) == k2
+
+ where
+   unField (Field x) = x
+
+-- | Test showing a struct.
+testUpdateStructFail :: Property
+testUpdateStructFail = expectFailure $
+   forAll arbitrary $ \k1 ->
+   forAll arbitrary $ \k3 ->
+     let f :: Field "field" Int8
+         f = Field k3
+         v :: Value Int8
+         v = Value Int8 f
+     in unField (s3 (updateField (S3 (Field k1)) v)) == k3
+
+ where
+   unField (Field x) = x
 
 -- | Test the accessorName of a field of a struct (should succeed).
 testAccessorNameOk :: Property
 testAccessorNameOk = property $
     accessorName s1 == s1FieldName
   where
-    s1FieldName = "field"
+    s1FieldName = "field1"
 
 -- | Test the accessorName of a field of a struct (should fail).
 testAccessorNameFail :: Property
 testAccessorNameFail = expectFailure $ property $
     accessorName s1 == s1FieldName
   where
-    s1FieldName = "Field"
+    s1FieldName = "Field1"
 
 -- | Test the typeName of a struct (should succeed).
 testTypeNameOk :: Property
@@ -309,7 +400,7 @@ testTypeNameOk = property $
   where
 
     sampleS :: S
-    sampleS = S (Field 0)
+    sampleS = S (Field 0) (Field 0)
 
     s1TypeName :: String
     s1TypeName = "S"
@@ -322,18 +413,39 @@ testTypeNameFail = expectFailure $ property $
   where
 
     sampleS :: S
-    sampleS = S (Field 0)
+    sampleS = S (Field 0) (Field 0)
 
     s1TypeName :: String
     s1TypeName = "s"
 
 -- | Auxiliary struct defined for testing purposes.
-data S = S { s1 :: Field "field" Int8 }
+data S = S { s1 :: Field "field1" Int8, s2 :: Field "field2" Word8 }
 
 instance Struct S where
   typeName _ = "S"
 
-  toValues s = [ Value Int8 (s1 s) ]
+  toValues s = [ Value Int8 (s1 s), Value Word8 (s2 s) ]
+
+  updateField s (Value fieldTy (field :: Field fieldName a))
+    | Just Refl <- sameSymbol (Proxy @"field1") (Proxy @fieldName)
+    , Just Refl <- testEquality Int8 fieldTy
+    = s { s1 = field }
+    | Just Refl <- sameSymbol (Proxy @"field2") (Proxy @fieldName)
+    , Just Refl <- testEquality Word8 fieldTy
+    = s { s2 = field }
+    | otherwise
+    = error $ "Unexpected field: " P.++ show field
 
 instance Typed S where
-  typeOf = Struct (S (Field 0))
+  typeOf = Struct (S (Field 0) (Field 0))
+
+-- | Auxiliary struct defined for testing purposes.
+data S3 = S3 { s3 :: Field "field" Int8 }
+
+instance Struct S3 where
+  typeName _ = "S3"
+
+  toValues s = [ Value Int8 (s3 s) ]
+
+instance Typed S3 where
+  typeOf = Struct (S3 (Field 0))