{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- Hack for bug in older Cabal versions #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) 1 #endif import Deriving import Control.Lens import Control.Lens.Action import Data.Array (Array) import Data.Array.Unboxed (UArray) import Data.Data.Lens import Data.Fixed (Fixed, E1) import Data.List import Data.SafeCopy.Store import Data.Store (decodeWith) import Data.Time (ZonedTime(..)) import Data.Tree (Tree) import Language.Haskell.TH import Language.Haskell.TH.Syntax import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.QuickCheck hiding (Fixed, (===)) #if ! MIN_VERSION_QuickCheck(2,9,0) instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f) => Arbitrary (a,b,c,d,e,f) where arbitrary = (,,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f, Arbitrary g) => Arbitrary (a,b,c,d,e,f,g) where arbitrary = (,,,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary #endif #if ! MIN_VERSION_QuickCheck(2,8,2) instance (Arbitrary a) => Arbitrary (V.Vector a) where arbitrary = V.fromList <$> arbitrary instance (Arbitrary a, VP.Prim a) => Arbitrary (VP.Vector a) where arbitrary = VP.fromList <$> arbitrary instance (Arbitrary a, VS.Storable a) => Arbitrary (VS.Vector a) where arbitrary = VS.fromList <$> arbitrary instance (Arbitrary a, VU.Unbox a) => Arbitrary (VU.Vector a) where arbitrary = VU.fromList <$> arbitrary #endif deriving instance (Arbitrary a) => Arbitrary (Prim a) deriving instance (Eq a) => Eq (Prim a) deriving instance (Show a) => Show (Prim a) deriving instance Eq ZonedTime #if ! MIN_VERSION_time(1,6,0) deriving instance Show UniversalTime #endif data Example = Example { exampleField1 :: String , exampleField2 :: Bool } deriving (Show, Eq) deriveSafeCopy 1 'base ''Example instance Arbitrary Example where arbitrary = Example <$> arbitrary <*> arbitrary -- | Equality on the 'Right' value, showing the unequal value on failure; -- or explicit failure using the 'Left' message without equality testing. (===) :: (Eq a, Show a) => Either PeekException a -> a -> Property Left e === _ = counterexample (show e) False Right a === b = counterexample (show a) $ a == b -- | An instance for 'SafeCopy' makes a type isomorphic to a bytestring -- serialization, which is to say that @decode . encode = id@, i.e. -- @decode@ is the inverse of @encode@ if we ignore bottom. prop_inverse :: (SafeCopy a, Arbitrary a, Eq a, Show a) => a -> Property prop_inverse a = (decode . encode) a === a where encode = runEncode . safePut decode = decodeWith safeGet -- | Test the 'prop_inverse' property against all 'SafeCopy' instances -- (that also satisfy the rest of the constraints) defaulting any type -- variables to 'Int'. do let a = conT ''Int -- types we skip because the Int defaulting doesn't type check excluded <- sequence [ [t| Fixed $a |] ] -- instead we include these hand-defaulted types included <- sequence [ [t| Fixed E1 |] , [t| Example |] ] -- types whose samples grow exponentially and need a lower maxSize downsized <- sequence [ [t| Array $a $a |] , [t| UArray $a $a |] , [t| Tree $a |] ] safecopy <- reify ''SafeCopy preds <- 'prop_inverse ^!! act reify . (template :: Traversal' Info Pred) #if !MIN_VERSION_template_haskell(2,10,0) classes <- mapM reify [ name | ClassP name _ <- preds ] #else -- print preds classes <- case preds of [ForallT _ cxt' _] -> mapM reify [ name | AppT (ConT name) _ <- cxt' ] _ -> error "FIXME: fix this code to handle this case." -- classes <- mapM reify [ ] #endif def <- a #if MIN_VERSION_template_haskell(2,11,0) let instances (ClassI _ decs) = [ typ | InstanceD _ _ (AppT _ typ) _ <- decs ] #else let instances (ClassI _ decs) = [ typ | InstanceD _ (AppT _ typ) _ <- decs ] #endif instances _ = [] types = map instances classes defaulting (VarT _) = def defaulting t = t defaulted = transformOn (traverse.traverse) defaulting types wanted = transformOn traverse defaulting $ instances safecopy common = foldl1 intersect defaulted untested = wanted \\ common exclusive = filter (`notElem` excluded) common downsize typ | typ `elem` downsized = [| mapSize (`div` 5) |] | otherwise = [| id |] unqualifying (Name occ _) = Name occ NameS name = pprint . transformOnOf template template unqualifying prop typ = [| testProperty $(litE . stringL $ name typ) ($(downsize typ) (prop_inverse :: $(return typ) -> Property)) |] props = listE . map prop #if !MIN_VERSION_template_haskell(2,8,0) -- 'report' throws warnings in template-haskell-2.8.0.0 reportWarning = report False #endif mapM_ (\typ -> reportWarning $ "not tested: " ++ name typ) untested [d| inversions :: [TestTree] inversions = $(props included) ++ $(props exclusive) |] main :: IO () main = defaultMain $ testGroup "SafeCopy instances" [ testGroup "decode is the inverse of encode" inversions ]