1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
|
{-# 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 Control.Applicative
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
import Data.Serialize (runPut, runGet)
import Data.Time (UniversalTime(..), 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, (===))
import qualified Data.Vector as V
import qualified Data.Vector.Primitive as VP
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU
#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
-- | 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 String a -> a -> Property
Left e === _ = printTestCase e False
Right a === b = printTestCase (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 = runPut . safePut
decode = runGet 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 |]
]
-- 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
]
|