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
|
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main (main) where
import Control.Monad (unless)
import Data.Aeson (Result(Success), Value(Array, Object), encode)
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.Aeson.KeyMap as HM
import qualified Data.Vector as V
import System.Exit (exitFailure)
import Test.QuickCheck (Arbitrary, Gen, arbitrary, oneof, quickCheckAll, resize, sized)
import Data.Aeson.Diff (Config(Config), diff, diff', patch)
import Data.Aeson.Patch (isRem, isTst, patchOperations)
showIt :: Value -> String
showIt = BL.unpack . encode
newtype Wellformed a = Wellformed { wellformed :: a }
newtype AnObject a = AnObject { anObject :: a }
newtype AnArray a = AnArray { anArray :: a }
instance Show (Wellformed Value) where
show = showIt . wellformed
instance Show (AnObject Value) where
show = showIt . anObject
instance Show (AnArray Value) where
show = showIt . anArray
-- | QuickCheck doesn't have scale in LTS-2 so copy it in.
scaleSize :: (Int -> Int) -> Gen a -> Gen a
scaleSize f g = sized (\s -> resize (f s) g)
instance Arbitrary (Wellformed Value) where
arbitrary = Wellformed <$> oneof
[ Array . V.fromList <$> scaleSize (`div` 2) arbitrary
, Object . HM.fromList <$> scaleSize (`div` 2) arbitrary
]
instance Arbitrary (AnObject Value) where
arbitrary = AnObject . Object . HM.fromList <$> scaleSize (`div` 2) arbitrary
instance Arbitrary (AnArray Value) where
arbitrary = AnArray . Array . V.fromList <$> scaleSize (`div` 2) arbitrary
-- | Extracting and applying a patch is an identity.
diffApply
:: Value
-> Value
-> Bool
diffApply f t =
let p = diff f t
in (Success t == patch p f) ||
error ("BAD PATCH\n" <> BL.unpack (encode p) <> "\n"
<> result "<failure>" (BL.unpack . encode <$> patch p f))
result :: a -> Result a -> a
result _ (Success a) = a
result a _ = a
-- | Patch extracted from identical documents should be mempty.
prop_diff_id
:: Wellformed Value
-> Bool
prop_diff_id (Wellformed v) =
diff v v == mempty
-- | Extract and apply a patch (between wellformed JSON documents).
prop_diff_documents
:: Wellformed Value
-> Wellformed Value
-> Bool
prop_diff_documents (Wellformed f) (Wellformed t) =
diffApply f t
-- | Extract and apply a patch (specialised to JSON arrays).
prop_diff_arrays
:: AnArray Value
-> AnArray Value
-> Bool
prop_diff_arrays (AnArray v1) (AnArray v2) =
diffApply v1 v2
-- | Extract and apply a patch (specialised to JSON objects).
prop_diff_objects
:: AnObject Value
-> AnObject Value
-> Bool
prop_diff_objects (AnObject m1) (AnObject m2) =
diffApply m1 m2
-- | Check that 'Rem' always preceded by a 'Tst'.
prop_tst_before_rem
:: Wellformed Value
-> Wellformed Value
-> Bool
prop_tst_before_rem (Wellformed f) (Wellformed t) =
let ops = zip [1..] (patchOperations $ diff' (Config True) f t)
rs = map fst . filter (isRem . snd) $ ops
ts = map fst . filter (isTst . snd) $ ops
minusOneInTs :: Integer -> Bool
minusOneInTs r = (r - 1) `elem` ts
in (length rs <= length ts) && all minusOneInTs rs
--
-- Use Template Haskell to automatically run all of the properties above.
--
return []
runTests :: IO Bool
runTests = $quickCheckAll
main :: IO ()
main = do
result <- runTests
unless result exitFailure
|
