From 40a431c743763a5d24327b387fecf079dc74555a Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 15 May 2024 17:20:44 +1200 Subject: [PATCH] fuzz-test MessagePack implementations. --- fontconfig-pure.cabal | 7 ++++-- lib/Graphics/Text/Font/Choose/CharSet.hs | 10 ++++++-- lib/Graphics/Text/Font/Choose/LangSet.hs | 8 ++++++- lib/Graphics/Text/Font/Choose/Pattern.hs | 14 +++++++++++- lib/Graphics/Text/Font/Choose/Range.hs | 9 +++++++- lib/Graphics/Text/Font/Choose/StrSet.hs | 5 +++- lib/Graphics/Text/Font/Choose/Value.hs | 24 ++++++++++++++++++-- lib/MyLib.hs | 4 ---- test/Main.hs | 29 +++++++++++++++++++++++- 9 files changed, 95 insertions(+), 15 deletions(-) delete mode 100644 lib/MyLib.hs diff --git a/fontconfig-pure.cabal b/fontconfig-pure.cabal index d70fbcd..de54bc4 100644 --- a/fontconfig-pure.cabal +++ b/fontconfig-pure.cabal @@ -87,7 +87,8 @@ library build-depends: base >=4.12 && <5, containers >=0.1 && <1, css-syntax, freetype2 >=0.2 && <0.3, hashable >=1.3 && <2, linear >=1.0.1 && <2, scientific, stylist-traits >=0.1.1 && <1, text, msgpack >= 1.0 && <2, - vector >= 0.13 && <1, bytestring, stylist-traits, css-syntax + vector >= 0.13 && <1, bytestring, stylist-traits, css-syntax, + QuickCheck -- Directories containing source files. hs-source-dirs: lib @@ -144,4 +145,6 @@ test-suite fontconfig-pure-test -- Test dependencies. build-depends: base ^>=4.17.0.0, - fontconfig-pure + fontconfig-pure, + hspec, QuickCheck, + msgpack diff --git a/lib/Graphics/Text/Font/Choose/CharSet.hs b/lib/Graphics/Text/Font/Choose/CharSet.hs index f09f8d1..c8e69c0 100644 --- a/lib/Graphics/Text/Font/Choose/CharSet.hs +++ b/lib/Graphics/Text/Font/Choose/CharSet.hs @@ -8,6 +8,7 @@ import Data.Char (isHexDigit, ord, chr) import Numeric (readHex) import Data.MessagePack (MessagePack(..)) +import Test.QuickCheck (Arbitrary(..)) -- | An FcCharSet is a set of Unicode characters. type CharSet = IntSet @@ -51,8 +52,13 @@ diffDecompress :: Int -> [Int] -> [Int] diffDecompress prev (x:xs) = let y = prev + x in y:diffDecompress y xs diffDecompress _ [] = [] -newtype CharSet' = CharSet' { unCharSet :: CharSet } +newtype CharSet' = CharSet' { unCharSet :: CharSet } deriving (Eq, Read, Show) instance MessagePack CharSet' where - toObject = toObject . diffCompress 0 . IntSet.toAscList . unCharSet + toObject x = toObject $ diffCompress 0 $ IntSet.toAscList $ unCharSet x fromObject msg = CharSet' <$> IntSet.fromAscList <$> diffDecompress 0 <$> fromObject msg +instance Arbitrary CharSet' where + arbitrary = do + x <- arbitrary -- Ensure its non-empty, known failure! + xs <- arbitrary + return $ CharSet' $ IntSet.insert x xs diff --git a/lib/Graphics/Text/Font/Choose/LangSet.hs b/lib/Graphics/Text/Font/Choose/LangSet.hs index 310cd92..bbeb9da 100644 --- a/lib/Graphics/Text/Font/Choose/LangSet.hs +++ b/lib/Graphics/Text/Font/Choose/LangSet.hs @@ -7,6 +7,7 @@ import Data.Set (Set) import qualified Data.Set as S import Data.MessagePack (MessagePack(..)) +import Test.QuickCheck (Arbitrary(..)) import Graphics.Text.Font.Choose.StrSet (StrSet) import Graphics.Text.Font.Choose.CharSet (CharSet') @@ -17,11 +18,16 @@ import Graphics.Text.Font.Choose.Result import Control.Exception (throw) type LangSet = Set String -newtype LangSet' = LangSet' { unLangSet :: LangSet } +newtype LangSet' = LangSet' { unLangSet :: LangSet } deriving (Eq, Show, Read) instance MessagePack LangSet' where toObject = toObject . S.toList . unLangSet fromObject msg = LangSet' <$> S.fromList <$> fromObject msg +instance Arbitrary LangSet' where + arbitrary = do + x <- arbitrary -- Ensure non-empty, known failure + xs <- arbitrary + return $ LangSet' $ S.insert x xs data LangComparison = SameLang | SameTerritory | DifferentLang i2cmp :: Int -> LangComparison diff --git a/lib/Graphics/Text/Font/Choose/Pattern.hs b/lib/Graphics/Text/Font/Choose/Pattern.hs index c10eef7..4c3410f 100644 --- a/lib/Graphics/Text/Font/Choose/Pattern.hs +++ b/lib/Graphics/Text/Font/Choose/Pattern.hs @@ -8,6 +8,7 @@ module Graphics.Text.Font.Choose.Pattern(Pattern, Pattern'(..), module M, Bindin import Data.Map as M import Data.MessagePack (MessagePack(..), Object(..)) +import Test.QuickCheck (Arbitrary(..), chooseEnum) import Data.Hashable (Hashable(..)) import GHC.Generics (Generic) @@ -24,12 +25,13 @@ import Graphics.Text.Font.Choose.Weight import Stylist (PropertyParser(..)) import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..)) import Data.Text (Text, unpack) +import qualified Data.Text as Txt import Data.Scientific (toRealFloat) import Data.List (intercalate) import Data.Maybe as Mb (listToMaybe, fromMaybe, mapMaybe) type Pattern = Map Text [(Binding, Value)] -data Pattern' = Pattern' { unPattern :: Pattern } +data Pattern' = Pattern' { unPattern :: Pattern } deriving (Eq, Read, Show, Generic) data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Read, Show, Generic) instance Hashable Binding where @@ -43,6 +45,16 @@ instance MessagePack Binding where toObject Weak = ObjectBool False toObject Same = ObjectNil +instance Hashable Pattern' where hash = hash . unPattern +instance MessagePack Pattern' where + fromObject = fmap Pattern' . fromObject + toObject = toObject . unPattern + +instance Arbitrary Pattern' where + arbitrary = Pattern' <$> M.mapKeys Txt.pack <$> arbitrary +instance Arbitrary Binding where + arbitrary = chooseEnum (Strong, Same) + setValue :: ToValue v => Text -> Binding -> v -> Pattern -> Pattern setValue key strength v self = setValues key strength [v] self setValues :: ToValue v => Text -> Binding -> [v] -> Pattern -> Pattern diff --git a/lib/Graphics/Text/Font/Choose/Range.hs b/lib/Graphics/Text/Font/Choose/Range.hs index fb96b57..1d36597 100644 --- a/lib/Graphics/Text/Font/Choose/Range.hs +++ b/lib/Graphics/Text/Font/Choose/Range.hs @@ -1,11 +1,15 @@ +{-# LANGUAGE DeriveGeneric #-} module Graphics.Text.Font.Choose.Range(Range(..), iRange) where import Data.MessagePack (MessagePack(..), Object(..)) +import Test.QuickCheck (Arbitrary(..)) +import GHC.Generics (Generic(..)) +import Data.Hashable (Hashable(..)) import qualified Data.Vector as V import qualified Data.IntMap as IM -- | Matches a numeric range. -data Range = Range Double Double deriving (Eq, Show, Ord) +data Range = Range Double Double deriving (Eq, Read, Show, Ord, Generic) -- | Matches an integral range. iRange :: Int -> Int -> Range iRange i j = toEnum i `Range` toEnum j @@ -19,3 +23,6 @@ instance MessagePack Range where | Just msg' <- fromObject msg = Just (IM.findWithDefault 0 0 msg' `Range` IM.findWithDefault 0 1 msg') | otherwise = Nothing +instance Arbitrary Range where + arbitrary = uncurry Range <$> arbitrary +instance Hashable Range diff --git a/lib/Graphics/Text/Font/Choose/StrSet.hs b/lib/Graphics/Text/Font/Choose/StrSet.hs index 6ef8bac..4812a53 100644 --- a/lib/Graphics/Text/Font/Choose/StrSet.hs +++ b/lib/Graphics/Text/Font/Choose/StrSet.hs @@ -4,9 +4,12 @@ import Data.Set (Set) import qualified Data.Set as S import Data.MessagePack (MessagePack(..)) +import Test.QuickCheck (Arbitrary(..)) -newtype StrSet = StrSet { unStrSet :: Set String } +newtype StrSet = StrSet { unStrSet :: Set String } deriving (Eq, Show, Read) instance MessagePack StrSet where toObject = toObject . S.toList . unStrSet fromObject msg = StrSet <$> S.fromList <$> fromObject msg +instance Arbitrary StrSet where + arbitrary = StrSet <$> arbitrary diff --git a/lib/Graphics/Text/Font/Choose/Value.hs b/lib/Graphics/Text/Font/Choose/Value.hs index ca45c29..2291b19 100644 --- a/lib/Graphics/Text/Font/Choose/Value.hs +++ b/lib/Graphics/Text/Font/Choose/Value.hs @@ -1,14 +1,18 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveGeneric #-} module Graphics.Text.Font.Choose.Value(Value(..), ToValue(..)) where import Linear.Matrix (M22) import Linear.V2 (V2(..)) +import qualified Data.Vector as V import Graphics.Text.Font.Choose.CharSet (CharSet, CharSet'(..)) --import FreeType.Core.Base (FT_Face(..)) import Graphics.Text.Font.Choose.LangSet (LangSet, LangSet'(..)) import Graphics.Text.Font.Choose.Range (Range) import Data.MessagePack (MessagePack(..), Object(..)) +import Test.QuickCheck (Arbitrary(..), oneof) +import GHC.Generics (Generic) +import Data.Hashable (Hashable(..)) import qualified Data.Text as Txt -- | A dynamic type system for `Pattern`s. @@ -21,8 +25,9 @@ data Value = ValueVoid | ValueCharSet CharSet -- | ValueFTFace FT_Face -- FIXME: Is it worth going through the trouble to bridge this? | ValueLangSet LangSet - | ValueRange Range deriving (Eq, Show, Ord) + | ValueRange Range deriving (Eq, Read, Show, Ord, Generic) +instance Hashable Value instance MessagePack Value where toObject ValueVoid = ObjectNil toObject (ValueInt x) = ObjectInt x @@ -41,6 +46,7 @@ instance MessagePack Value where fromObject (ObjectDouble x) = Just $ ValueDouble x fromObject (ObjectStr x) = Just $ ValueString $ Txt.unpack x fromObject (ObjectBin _) = Nothing -- Would use for to transfer font faces via underlying bytes. + fromObject (ObjectArray x) | V.null x = Nothing -- Ambiguous! fromObject msg | Just charset <- fromObject msg = Just $ ValueCharSet $ unCharSet charset | Just langset <- fromObject msg = Just $ ValueLangSet $ unLangSet langset @@ -49,6 +55,20 @@ instance MessagePack Value where -- [Double] decoding is overly generous, potentially conflicts with above. Just $ ValueMatrix $ V2 (V2 xx yx) (V2 xy yy) | otherwise = Nothing +instance Arbitrary Value where + arbitrary = oneof [ + return ValueVoid, + ValueInt <$> arbitrary, + ValueDouble <$> arbitrary, + ValueString <$> arbitrary, + ValueBool <$> arbitrary, + do + (a, b, c, d) <- arbitrary + return $ ValueMatrix $ V2 (V2 a b) (V2 c d), + ValueCharSet <$> unCharSet <$> arbitrary, + ValueLangSet <$> unLangSet <$> arbitrary, + ValueRange <$> arbitrary + ] -- | Coerces compiletime types to runtime types. class ToValue x where diff --git a/lib/MyLib.hs b/lib/MyLib.hs deleted file mode 100644 index e657c44..0000000 --- a/lib/MyLib.hs +++ /dev/null @@ -1,4 +0,0 @@ -module MyLib (someFunc) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/test/Main.hs b/test/Main.hs index 3e2059e..b6bd147 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,31 @@ module Main (main) where +import Test.Hspec +import Test.Hspec.QuickCheck + +import Data.MessagePack as MP +import Graphics.Text.Font.Choose + main :: IO () -main = putStrLn "Test suite not yet implemented." +main = hspec $ do + describe "Canary" $ do + it "runs fine" $ do + True `shouldBe` True + describe "Roundtrips" $ do + describe "converts MessagePack & back" $ do + prop "CharSet" $ \x -> + MP.unpack (MP.pack x) `shouldBe` Just (x :: CharSet') + prop "FontSet" $ \x -> let y = Prelude.map unPattern x + in MP.unpack (MP.pack y) `shouldBe` Just y + prop "LangSet" $ \x -> + MP.unpack (MP.pack x) `shouldBe` Just (x :: LangSet') + prop "ObjectSet" $ \x -> + MP.unpack (MP.pack x) `shouldBe` Just (x :: ObjectSet) + prop "Pattern" $ \x -> + MP.unpack (MP.pack x) `shouldBe` Just (x :: Pattern') + prop "Range" $ \x -> + MP.unpack (MP.pack x) `shouldBe` Just (x :: Range) + prop "StrSet" $ \x -> + MP.unpack (MP.pack x) `shouldBe` Just (x :: StrSet) + prop "Value" $ \x -> + MP.unpack (MP.pack x) `shouldBe` Just (x :: Value) -- 2.30.2