From f24bee775905d89d92723ddc048597e4e093ff66 Mon Sep 17 00:00:00 2001 From: Ivan Perez Date: Mon, 12 Oct 2026 06:33:02 -0700 Subject: [PATCH] WIP to get to 100% coverage --- copilot-core/src/Copilot/Core/Type.hs | 59 ++++++++--------- copilot-core/tests/Test/Copilot/Core/Type.hs | 68 ++++++++++++++++++++ 2 files changed, 98 insertions(+), 29 deletions(-) diff --git a/copilot-core/src/Copilot/Core/Type.hs b/copilot-core/src/Copilot/Core/Type.hs index b290810c2..0340980e8 100644 --- a/copilot-core/src/Copilot/Core/Type.hs +++ b/copilot-core/src/Copilot/Core/Type.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} @@ -116,13 +117,13 @@ data Field (s :: Symbol) t = Field t -- | Extract the name of a field. fieldName :: forall s t . KnownSymbol s => Field s t -> String -fieldName _ = symbolVal (Proxy :: Proxy s) +fieldName (!_) = symbolVal $! (Proxy :: Proxy s) -- | 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) +accessorName _ = symbolVal $! (Proxy :: Proxy s) instance (KnownSymbol s, Show t) => Show (Field s t) where show f@(Field v) = fieldName f ++ ":" ++ show v @@ -159,7 +160,7 @@ deriving instance Show (Type a) -- | Return the length of an array from its type typeLength :: forall n t . KnownNat n => Type (Array n t) -> Int -typeLength _ = fromIntegral $ natVal (Proxy :: Proxy n) +typeLength (!_) = fromIntegral $ natVal $! (Proxy :: Proxy n) -- | Return the total (nested) size of an array from its type typeSize :: forall n t . KnownNat n => Type (Array n t) -> Int @@ -187,7 +188,7 @@ instance TestEquality Type where -> Type a2 -> Maybe (Array n1 a1 :~: Array n2 a2) testArrayEquality ty1 ty2 - | Just DE.Refl <- sameNat (Proxy :: Proxy n1) (Proxy :: Proxy n2) + | Just DE.Refl <- (sameNat $! (Proxy :: Proxy n1)) $! (Proxy :: Proxy n2) , Just DE.Refl <- testEquality ty1 ty2 = Just DE.Refl | otherwise @@ -238,61 +239,61 @@ instance Eq SimpleType where class (Show a, Typeable a) => Typed a where typeOf :: Type a simpleType :: Type a -> SimpleType - simpleType _ = SStruct + simpleType (!_) = SStruct instance Typed Bool where - typeOf = Bool - simpleType _ = SBool + typeOf = Bool + simpleType (!_) = SBool instance Typed Int8 where - typeOf = Int8 - simpleType _ = SInt8 + typeOf = Int8 + simpleType (!_) = SInt8 instance Typed Int16 where - typeOf = Int16 - simpleType _ = SInt16 + typeOf = Int16 + simpleType (!_) = SInt16 instance Typed Int32 where - typeOf = Int32 - simpleType _ = SInt32 + typeOf = Int32 + simpleType (!_) = SInt32 instance Typed Int64 where - typeOf = Int64 - simpleType _ = SInt64 + typeOf = Int64 + simpleType (!_) = SInt64 instance Typed Word8 where - typeOf = Word8 - simpleType _ = SWord8 + typeOf = Word8 + simpleType (!_) = SWord8 instance Typed Word16 where - typeOf = Word16 - simpleType _ = SWord16 + typeOf = Word16 + simpleType (!_) = SWord16 instance Typed Word32 where - typeOf = Word32 - simpleType _ = SWord32 + typeOf = Word32 + simpleType (!_) = SWord32 instance Typed Word64 where - typeOf = Word64 - simpleType _ = SWord64 + typeOf = Word64 + simpleType (!_) = SWord64 instance Typed Float where - typeOf = Float - simpleType _ = SFloat + typeOf = Float + simpleType (!_) = SFloat instance Typed Double where typeOf = Double - simpleType _ = SDouble + simpleType (!_) = SDouble instance (Typeable t, Typed t, KnownNat n) => Typed (Array n t) where - typeOf = Array typeOf - simpleType (Array t) = SArray t + typeOf = Array $! typeOf + simpleType (Array t) = SArray $! t -- | A untyped type (no phantom type). data UType = forall a . Typeable a => UType (Type a) instance Eq UType where - UType ty1 == UType ty2 = typeRep ty1 == typeRep ty2 + UType ty1 == UType ty2 = (typeRep $! ty1) == (typeRep $! ty2) -- * GHC.Generics-based defaults diff --git a/copilot-core/tests/Test/Copilot/Core/Type.hs b/copilot-core/tests/Test/Copilot/Core/Type.hs index 9f9cb6d5e..0cb32bbf1 100644 --- a/copilot-core/tests/Test/Copilot/Core/Type.hs +++ b/copilot-core/tests/Test/Copilot/Core/Type.hs @@ -7,6 +7,7 @@ module Test.Copilot.Core.Type where -- External imports import Data.Int (Int16, Int32, Int64, Int8) +import Data.List (intercalate) import Data.Maybe (isJust) import Data.Proxy (Proxy (..)) import Data.Type.Equality (TestEquality (..), testEquality, @@ -18,6 +19,7 @@ import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Gen, Property, arbitrary, elements, expectFailure, forAll, forAllBlind, + getNonNegative, listOf1, property, shuffle, (==>)) -- Internal imports: library modules being tested @@ -49,6 +51,12 @@ tests = testTypeSize1 , testProperty "typeSize matches full array size for 2-dimensional arrays" testTypeSize2 + , testProperty "show for types" + testTypeShow + , testProperty "show prec for types" + testTypeShowsPrec + , testProperty "show list for types" + testTypeShowList , testProperty "equality of types" testUTypesEqualitySymmetric , testProperty "equality of utype" @@ -65,8 +73,16 @@ tests = testFieldNameFail , testProperty "Show field name" testShowField + , testProperty "Show field precedence name" + testShowsPrecField + , testProperty "Show field list" + testShowListField , testProperty "Show struct" testShowStruct + , testProperty "Shows prec struct" + testShowsPrecStruct + , testProperty "Show list struct" + testShowListStruct , testProperty "Update struct" testUpdateStruct , testProperty "Update struct" @@ -227,6 +243,24 @@ testTypesInequality = forAllBlind twoDiffTypes $ \(UType t1, UType t2) -> (t1:t2:_) -> return (t1, t2) _ -> return (UType Bool, UType Bool) +testTypeShow :: Property +testTypeShow = property $ show a == "Array (Array Int8)" + where + a :: Type (Array 3 (Array 12 Int8)) + a = Array (Array Int8) + +testTypeShowsPrec :: Property +testTypeShowsPrec = property $ showsPrec 0 a "" == defaultShowsPrec 0 a "" + where + a :: Type (Array 3 (Array 12 Int8)) + a = Array (Array Int8) + +testTypeShowList :: Property +testTypeShowList = property $ showList a "" == defaultShowList a "" + where + a :: [ Type (Array 3 (Array 12 Int8)) ] + a = [ Array (Array Int8) ] + -- | Different UTypes. utypes :: [UType] utypes = @@ -344,12 +378,40 @@ testShowField :: Property testShowField = forAll arbitrary $ \k -> show (s1 (S (Field k) (Field 0))) == ("field1:" ++ show k) +-- | Test showing a field of a struct. +testShowsPrecField :: Property +testShowsPrecField = forAll (getNonNegative <$> arbitrary) $ \prec -> + forAll arbitrary $ \k -> + let v = (s1 (S (Field k) (Field 0))) + in showsPrec prec v "" == defaultShowsPrec prec v "" -- "field1:" ++ show k + +-- | Test showing a field of a struct. +testShowListField :: Property +testShowListField = forAll (listOf1 arbitrary) $ \l -> property $ + let v = map (\k -> s1 (S (Field k) (Field 0))) l + in showList v "" == defaultShowList v "" + -- let x = showList (map (\k -> s1 (S (Field k) (Field 0))) l) "" + -- y = "[" ++ intercalate "," (map (\k -> ("field1:" ++ show k)) l) ++ "]" + -- in x == y + -- | Test showing a struct. testShowStruct :: Property testShowStruct = forAll arbitrary $ \k1 -> forAll arbitrary $ \k2 -> show (S (Field k1) (Field k2)) == "" +testShowsPrecStruct :: Property +testShowsPrecStruct = forAll (getNonNegative <$> arbitrary) $ \prec -> + forAll arbitrary $ \k1 -> + forAll arbitrary $ \k2 -> + showsPrec prec (S (Field k1) (Field k2)) "" == "" + +testShowListStruct :: Property +testShowListStruct = forAll (listOf1 arbitrary) $ \l -> + let x = showList (map (\(k1, k2) -> (S (Field k1) (Field k2))) l) "" + y = "[" ++ intercalate "," (map (\(k1, k2) -> "") l) ++ "]" + in x == y + -- | Test showing a struct. testUpdateStruct :: Property testUpdateStruct = @@ -449,3 +511,9 @@ instance Struct S3 where instance Typed S3 where typeOf = Struct (S3 (Field 0)) + +defaultShowList :: Show a => [a] -> String -> String +defaultShowList l s = "[" ++ intercalate "," (map show l) ++ "]" ++ s + +defaultShowsPrec :: Show a => Int -> a -> String -> String +defaultShowsPrec _ x s = show x ++ s