copilot-core 3.18.1 → 3.19

raw patch · 6 files changed

+268/−46 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +6/−0
• copilot-core.cabal +1/−1
• src/Copilot/Core/Type.hs +0/−34
• src/Copilot/Core/Type/Array.hs +0/−6
• tests/Test/Copilot/Core/Type.hs +242/−3
• tests/Test/Copilot/Core/Type/Array.hs +19/−2

@@ -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) 

@@ -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.

@@ -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

@@ -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

@@ -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)) == "<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))

@@ -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])