diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +2024-03-07 + * Version bump (3.19). (#504) + * 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.cabal b/copilot-core.cabal --- a/copilot-core.cabal +++ b/copilot-core.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: copilot-core -version: 3.18.1 +version: 3.19 synopsis: An intermediate representation for Copilot. description: Intermediate representation for Copilot. diff --git a/src/Copilot/Core/Type.hs b/src/Copilot/Core/Type.hs --- a/src/Copilot/Core/Type.hs +++ b/src/Copilot/Core/Type.hs @@ -24,21 +24,16 @@ , SimpleType (..) , typeSize - , tysize , typeLength - , tylength , Value (..) , toValues , Field (..) , typeName - , typename , Struct , fieldName - , fieldname , accessorName - , accessorname ) where @@ -55,19 +50,12 @@ -- Internal imports import Copilot.Core.Type.Array (Array) -{-# DEPRECATED typename "Use typeName instead." #-} - -- | The value of that is a product or struct, defined as a constructor with -- several fields. class Struct a where -- | Returns the name of struct in the target language. typeName :: a -> String - typeName = typename - -- | Returns the name of struct in the target language. - typename :: a -> String - typename = typeName - -- | Transforms all the struct's fields into a list of values. toValues :: a -> [Value a] @@ -83,24 +71,12 @@ fieldName :: forall s t . KnownSymbol s => Field s t -> String fieldName _ = symbolVal (Proxy :: Proxy s) -{-# DEPRECATED fieldname "Use fieldName instead." #-} --- | Extract the name of a field. -fieldname :: forall s t . KnownSymbol s => Field s t -> String -fieldname = fieldName - -- | Extract the name of an accessor (a function that returns a field of a -- struct). accessorName :: forall a s t . (Struct a, KnownSymbol s) => (a -> Field s t) -> String accessorName _ = symbolVal (Proxy :: Proxy s) -{-# DEPRECATED accessorname "Use accessorName instead." #-} --- | Extract the name of an accessor (a function that returns a field of a --- struct). -accessorname :: forall a s t . (Struct a, KnownSymbol s) - => (a -> Field s t) -> String -accessorname = accessorName - instance (KnownSymbol s, Show t) => Show (Field s t) where show f@(Field v) = fieldName f ++ ":" ++ show v @@ -137,20 +113,10 @@ typeLength :: forall n t . KnownNat n => Type (Array n t) -> Int typeLength _ = fromIntegral $ natVal (Proxy :: Proxy n) -{-# DEPRECATED tylength "Use typeLength instead." #-} --- | Return the length of an array from its type -tylength :: forall n t . KnownNat n => Type (Array n t) -> Int -tylength = typeLength - -- | Return the total (nested) size of an array from its type typeSize :: forall n t . KnownNat n => Type (Array n t) -> Int typeSize ty@(Array ty'@(Array _)) = typeLength ty * typeSize ty' typeSize ty@(Array _ ) = typeLength ty - -{-# DEPRECATED tysize "Use typeSize instead." #-} --- | Return the total (nested) size of an array from its type -tysize :: forall n t . KnownNat n => Type (Array n t) -> Int -tysize = typeSize instance TestEquality Type where testEquality Bool Bool = Just DE.Refl diff --git a/src/Copilot/Core/Type/Array.hs b/src/Copilot/Core/Type/Array.hs --- a/src/Copilot/Core/Type/Array.hs +++ b/src/Copilot/Core/Type/Array.hs @@ -14,7 +14,6 @@ ( Array , array , arrayElems - , arrayelems ) where @@ -43,8 +42,3 @@ -- | Return the elements of an array. arrayElems :: Array n a -> [a] arrayElems (Array xs) = xs - -{-# DEPRECATED arrayelems "Use ArrayElems instead." #-} --- | Return the elemts of an array. -arrayelems :: Array n a -> [a] -arrayelems = arrayElems diff --git a/tests/Test/Copilot/Core/Type.hs b/tests/Test/Copilot/Core/Type.hs --- a/tests/Test/Copilot/Core/Type.hs +++ b/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 @@ 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 @@ , 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 @@ , 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)) == "" + +-- | 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/tests/Test/Copilot/Core/Type/Array.hs b/tests/Test/Copilot/Core/Type/Array.hs --- a/tests/Test/Copilot/Core/Type/Array.hs +++ b/tests/Test/Copilot/Core/Type/Array.hs @@ -9,8 +9,9 @@ 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 @@ (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 @@ -- 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])