aeson-diff (empty) → 0.1.1.1
raw patch · 9 files changed
+816/−0 lines, 9 filesdep +QuickCheckdep +aesondep +aeson-diffsetup-changed
Dependencies added: QuickCheck, aeson, aeson-diff, base, bytestring, edit-distance-vector, hashable, mtl, optparse-applicative, quickcheck-instances, scientific, text, unordered-containers, vector
Files
- CHANGELOG.md +3/−0
- LICENSE +26/−0
- README.md +85/−0
- Setup.hs +2/−0
- aeson-diff.cabal +73/−0
- lib/Data/Aeson/Diff.hs +343/−0
- src/diff.hs +107/−0
- src/patch.hs +110/−0
- test/properties.hs +67/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+aeson-diff 1.0++ * Initial release.
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2014, Thomas Sutton+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the+ distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,85 @@+Aeson Diff+==========++[![Build Status][badge]][status]++This is a small library for working with changes to JSON documents. It includes+a library and two executables in the style of diff(1) and patch(1).++Installing+----------++The `aeson-diff` package is written in Haskell and can be installed using the+Cabal package management tool.++For the command-line tools only, I recommend using Cabal's sandbox+functionality to avoid installing the associated libraries globally on your+system. This approach might look something like the following:++````bash+cd aeson-diff/+cabal sandbox init+cabal install --dependencies-only+cabal build+sudo mkdir -p /usr/local/bin+sudo cp dist/build/json-*/json-{diff,patch} /usr/local/bin/+````++If you want to use the library, use Cabal in a sandbox or not according to your+preference.++````bash+cabal sandbox init+cabal sandbox install ~/Downloads/aeson-diff/+````++Usage+-----++### json-diff command++The `json-diff` command compares two JSON documents and extracts a patch+describing the differences between the first document and the second.++````+Usage: json-diff [-j|--json] [-o|--output OUTPUT] FROM TO+Generate a patch between two JSON documents.++Available options:+ -h,--help Show this help text+ -j,--json Output patch in JSON.+````++### json-patch command++The `json-patch` command applies a patch describing changes to be made to+a JSON document.++````+Usage: json-patch [-j|--json] [-o|--output OUTPUT] PATCH FROM+Generate a patch between two JSON documents.++Available options:+ -h,--help Show this help text+ -j,--json Patch is in JSON format.+ -o,--output OUTPUT Destination for patched JSON.+ PATCH Patch to apply.+ FROM JSON file to patch.+````++### aeson-diff library++The `aeson-diff` library exports as single module: `Data.Aeson.Diff`. This+exports `diff` and `patch` functions which do exactly what might be expected:++- `diff :: Value -> Value -> Patch` examines source and target JSON `Value`s+and constructs a new `Patch` describing the changes.++- `patch :: Patch -> Value -> Value` applies the changes in a `Patch` to a JSON+`Value`.++For more complete information, see the [documentation][docs].++[badge]: https://travis-ci.org/thsutton/aeson-diff.svg?branch=master+[status]: https://travis-ci.org/thsutton/aeson-diff+[docs]: https://hackage.haskell.org/package/aeson-diff/docs/Data-Aeson-Diff.html
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aeson-diff.cabal view
@@ -0,0 +1,73 @@+name: aeson-diff+version: 0.1.1.1+synopsis: Extract and apply patches to JSON documents.+description:+ .+ This is a small library for working with changes to JSON documents. It+ includes a library and two command-line executables in the style of the+ diff(1) and patch(1) commands available on many systems.+ .+homepage: https://github.com/thsutton/aeson-diff+license: BSD3+license-file: LICENSE+author: Thomas Sutton+maintainer: me@thomas-sutton.id.au+copyright: (c) 2015 Thomas Sutton and others.+category: JSON, Web, Algorithms+build-type: Simple+extra-source-files: README.md, CHANGELOG.md+cabal-version: >=1.10++source-repository HEAD+ type: git+ location: https://github.com/thsutton/aeson-diff++library+ default-language: Haskell2010+ hs-source-dirs: lib+ exposed-modules: Data.Aeson.Diff+ build-depends: base >=4.7 && <4.9+ , aeson >=0.8 && <0.9+ , bytestring+ , edit-distance-vector >=1.0 && <2.0+ , hashable+ , mtl+ , scientific+ , text+ , unordered-containers+ , vector++executable json-diff+ default-language: Haskell2010+ hs-source-dirs: src+ main-is: diff.hs+ build-depends: base+ , aeson+ , aeson-diff+ , bytestring+ , optparse-applicative >=0.11 && < 0.12+ , text++executable json-patch+ default-language: Haskell2010+ hs-source-dirs: src+ main-is: patch.hs+ build-depends: base+ , aeson+ , aeson-diff+ , bytestring+ , optparse-applicative >=0.11 && < 0.12++test-suite properties+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: properties.hs+ build-depends: base+ , QuickCheck+ , aeson+ , aeson-diff+ , quickcheck-instances+ , text+ , unordered-containers+ , vector
+ lib/Data/Aeson/Diff.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Description: Extract and apply patches on JSON documents.+--+-- This module implements data types and operations to represent the+-- differences between JSON documents (i.e. a patch), to compare JSON documents+-- and extract such a patch, and to apply such a patch to a JSON document.+module Data.Aeson.Diff (+ -- * Patches+ Patch,+ patchOperations,+ Path,+ Key(..),+ Operation(..),++ -- * Functions+ diff,+ patch,+ applyOperation,++ formatPatch,+) where++import Control.Applicative+import Control.Monad+import Control.Monad.Error.Class+import Data.Aeson+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.Maybe+import Data.Monoid+import Data.Scientific+import Data.Text (Text)+import qualified Data.Text as T+import Data.Vector (Vector)+import qualified Data.Vector as V++import Data.Vector.Distance++-- | Describes the changes between two JSON documents.+data Patch = Patch+ { patchOperations :: [Operation] }+ deriving (Eq)++instance Show Patch where+ show = T.unpack . formatPatch++instance Monoid Patch where+ mempty = Patch []+ mappend (Patch p1) (Patch p2) = Patch $ p1 <> p2++instance ToJSON Patch where+ toJSON (Patch ops) = object [ "patch" .= ops ]++instance FromJSON Patch where+ parseJSON (Object v) = Patch <$> v .: "patch"+ parseJSON _ = fail "Patch must be a JSON object."++instance ToJSON Operation where+ toJSON (Ins p v) = object+ [ ("change", "insert")+ , "path" .= p+ , "value" .= v+ ]+ toJSON (Del p v) = object+ [ ("change", "delete")+ , "path" .= p+ , "value" .= v+ ]++instance FromJSON Operation where+ parseJSON (Object v)+ = (fixed v "change" (String "insert") *>+ (Ins <$> v .: "path" <*> v .: "value"))+ <> (fixed v "change" (String "delete") *>+ (Del <$> v .: "path" <*> v .: "value"))+ where+ fixed o n val = do+ v' <- o .: n+ unless (v' == val) . fail . T.unpack $ "Cannot find " <> n <> "."+ return v'+ parseJSON _ = fail "Operation must be a JSON object."++-- | Descripts an atomic change to a JSON document.+data Operation+ = Ins { changePath :: Path, changeValue :: Value }+ -- ^ Insert a value at a location.+ | Del { changePath :: Path, changeValue :: Value }+ -- ^ Delete the value at a location.+ deriving (Eq, Show)++-- | A path through a JSON document is a possibly empty sequence of 'Key's.+type Path = [Key]++-- | Traverse a single layer of a JSON document.+data Key+ = OKey Text+ | AKey Int+ deriving (Eq, Ord, Show)++instance ToJSON Key where+ toJSON (OKey t) = String t+ toJSON (AKey a) = Number . fromInteger . toInteger $ a++instance FromJSON Key where+ parseJSON (String t) = return $ OKey t+ parseJSON (Number n) =+ case toBoundedInteger n of+ Nothing -> fail "A numeric key must be a positive whole number."+ Just n' -> return $ AKey n'+ parseJSON _ = fail "A key element must be a number or a string."++-- | Modify the 'Path' of an 'Operation'.+modifyPath :: (Path -> Path) -> Operation -> Operation+modifyPath path op = op { changePath = path (changePath op) }++-- * Atomic patches++-- | Construct a patch with a single 'Ins' operation.+ins :: Path -> Value -> Patch+ins p v = Patch [Ins p v]++-- | Construct a patch with a single 'Del' operation.+del :: Path -> Value -> Patch+del p v = Patch [Del p v]++-- | Construct a patch which changes a single value.+ch :: Path -> Value -> Value -> Patch+ch p v1 v2 = del p v1 <> ins p v2++-- * Operations++-- | Compare two JSON documents and generate a patch describing the differences.+diff+ :: Value+ -> Value+ -> Patch+diff = worker []+ where+ check :: Monoid m => Bool -> m -> m+ check b v = if b then mempty else v++ worker :: Path -> Value -> Value -> Patch+ worker p v1 v2 = case (v1, v2) of+ -- For atomic values of the same type, emit changes iff they differ.+ (Null, Null) -> mempty+ (Bool b1, Bool b2) -> check (b1 == b2) $ ch p v1 v2+ (Number n1, Number n2) -> check (n1 == n2) $ ch p v1 v2+ (String s1, String s2) -> check (s1 == s2) $ ch p v1 v2++ -- For structured values of the same type, walk them.+ (Array a1, Array a2) -> check (a1 == a2) $ workArray p a1 a2+ (Object o1, Object o2) -> check (o1 == o2) $ workObject p o1 o2++ -- For values of different types, delete v1 and insert v2.+ _ -> del p v1 <> ins p v2++ -- Walk the keys in two objects, producing a 'Patch'.+ workObject :: Path -> Object -> Object -> Patch+ workObject p o1 o2 =+ let k1 = HM.keys o1+ k2 = HM.keys o2+ -- Deletions+ del_keys = filter (not . (`elem` k2)) k1+ deletions = Patch $ fmap+ (\k -> Del (p <> [OKey k]) . fromJust $ HM.lookup k o1)+ del_keys+ -- Insertions+ ins_keys = filter (not . (`elem` k1)) k2+ insertions = Patch $ fmap+ (\k -> Ins (p <> [OKey k]) . fromJust $ HM.lookup k o2)+ ins_keys+ -- Changes+ chg_keys = filter (`elem` k2) k1+ changes = fmap+ (\k -> worker (p <> [OKey k])+ (fromJust $ HM.lookup k o1)+ (fromJust $ HM.lookup k o2))+ chg_keys+ in deletions <> insertions <> mconcat changes++ -- Use an adaption of the Wagner-Fischer algorithm to find the shortest+ -- sequence of changes between two JSON arrays.+ workArray :: Path -> Array -> Array -> Patch+ workArray path ss tt = Patch . snd . fmap concat $ leastChanges params ss tt+ where+ params :: Params Value [Operation] (Sum Int)+ params = Params{..}+ equivalent = (==)+ delete i v = [Del (path <> [AKey i]) v]+ insert i v = [Ins (path <> [AKey i]) v]+ substitute i v v' =+ let p = path <> [AKey i]+ Patch ops = diff v v'+ in fmap (modifyPath (p <>)) ops+ cost = Sum . sum . fmap (valueSize . changeValue)+ positionOffset = sum . fmap pos+ pos Del{} = 0+ pos Ins{} = 1++-- | Apply a patch to a JSON document.+patch+ :: Patch+ -> Value+ -> Value+patch (Patch []) val = val+patch (Patch ops) val = foldl (flip applyOperation) val ops++-- | Apply an 'Operation' to a 'Value'.+applyOperation+ :: Operation+ -> Value+ -> Value+applyOperation op j = case op of+ Ins path v' -> insert path v' j+ Del path v' -> delete path v' j+ where+ insert :: Path -> Value -> Value -> Value+ insert [] v' _ = v'+ -- Apply a local change.+ insert [AKey i] v' (Array v) = Array $ vInsert i v' v+ insert [OKey n] v' (Object m) = Object $ HM.insert n v' m+ -- Traverse for deeper changes.+ insert (AKey i : path) v' (Array v) = Array $ vModify i+ (Just . insert path v' . fromMaybe (Array mempty)) v+ insert (OKey n : path) v' (Object m) = Object $ hmModify n+ (Just . insert path v' . fromMaybe (Object mempty)) m+ -- Hey I just met you / And this is crazy+ -- But here's my data / Discard it maybe?+ --+ -- Type mismatch; let's throw away the thing we weren't expecting!+ insert (AKey _ : path) v' v = Array $ V.singleton (insert path v' v)+ insert (OKey n : path) v' v = Object $ HM.singleton n (insert path v' v)++ delete :: Path -> Value -> Value -> Value+ -- Apply a local change.+ --+ -- TODO(thsutton) We might want to check that the item addressed by the key+ -- is similar to @_v'@.+ delete [AKey i] _v' (Array v) = Array $ vDelete i v+ delete [OKey n] _v' (Object m) = Object $ HM.delete n m+ -- Traverse for deeper changes.+ delete (AKey i : rest) v' (Array v) = Array $ vModify i+ (fmap (delete rest v')) v+ delete (OKey n : rest) v' (Object m) = Object $ hmModify n+ (fmap (delete rest v')) m+ -- Type mismatch: clearly the thing we're deleting isn't here.+ delete _ _v' v = v++-- * Formatting patches++-- | Format a 'Patch'.+formatPatch :: Patch -> Text+formatPatch (Patch ops) = T.unlines+ $ fmap formatOp ops+ where+ formatKey (OKey t) = "." <> t+ formatKey (AKey i) = "[" <> (T.pack . show $ i) <> "]"+ formatPath :: [Key] -> Text+ formatPath p = "@" <> (T.concat . fmap formatKey $ p)+ formatOp :: Operation -> Text+ formatValue :: Value -> Text+ formatValue v = case v of+ String t -> t+ Number s -> T.pack . show $ s+ Bool b -> T.pack . show $ b+ Null -> "Null"+ _ -> ":-("+ formatOp (Ins k v) = formatPath k <> "\n" <> "+" <> formatValue v+ formatOp (Del k v) = formatPath k <> "\n" <> "-" <> formatValue v++-- | Parse a 'Patch'.+parsePatch :: Text -> Either Text Patch+parsePatch _t = throwError "Cannot parse"++-- * Utilities+--+-- $ These are some utility functions used in the functions defined above. Mostly+-- they just fill gaps in the APIs of the "Data.Vector" and "Data.HashMap.Strict"+-- modules.++-- | Estimate the size of a JSON 'Value'.+--+-- This is used in the diff cost metric function.+valueSize :: Value -> Int+valueSize val = case val of+ Object o -> sum . fmap valueSize . HM.elems $ o+ Array a -> V.sum $ V.map valueSize a+ _ -> 1++-- | Delete an element in a vector.+vDelete :: Int -> Vector a -> Vector a+vDelete i v =+ let l = V.length v+ in V.slice 0 i v <> V.slice (i + 1) (l - i - 1) v++-- | Insert an element into a vector.+vInsert :: Int -> a -> Vector a -> Vector a+vInsert i a v+ | i <= 0 = V.cons a v+ | V.length v <= i = V.snoc v a+ | otherwise = V.slice 0 i v+ <> V.singleton a+ <> V.slice i (V.length v - i) v++-- | Modify the element at an index in a 'Vector'.+--+-- The function is passed the value at index @i@, or 'Nothing' if there is no+-- such element. The function should return 'Nothing' if it wants to have no+-- value corresponding to the index, or 'Just' if it wants a value.+--+-- Depending on the vector and the function, we will either:+--+-- - leave the vector unchanged;+-- - delete an existing element;+-- - insert a new element; or+-- - replace an existing element.+vModify :: Int -> (Maybe a -> Maybe a) -> Vector a -> Vector a+vModify i f v =+ let a = v V.!? i+ a' = f a+ in case (a, a') of+ (Nothing, Nothing) -> v+ (Just _, Nothing) -> vDelete i v+ (Nothing, Just n ) -> vInsert i n v+ (Just _, Just n ) -> V.update v (V.singleton (i, n))++-- | Modify the value associated with a key in a 'HashMap'.+--+-- The function is passed the value defined for @k@, or 'Nothing'. If the+-- function returns 'Nothing', the key and value are deleted from the map;+-- otherwise the value replaces the existing value in the returned map.+hmModify+ :: (Eq k, Hashable k)+ => k+ -> (Maybe v -> Maybe v)+ -> HashMap k v+ -> HashMap k v+hmModify k f m = case f (HM.lookup k m) of+ Nothing -> HM.delete k m+ Just v -> HM.insert k v m
+ src/diff.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Control.Applicative+import Control.Exception+import Data.Aeson+import Data.Aeson.Diff+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Monoid+import qualified Data.Text.IO as T+import Options.Applicative+import Options.Applicative.Types+import System.IO++type File = Maybe FilePath++-- | Command-line options.+data Options = Options+ { optionJSON :: Bool+ , optionOut :: File+ , optionFrom :: File+ , optionTo :: File+ }++data Configuration = Configuration+ { cfgJSON :: Bool+ , cfgOut :: Handle+ , cfgFrom :: Handle+ , cfgTo :: Handle+ }++optionParser :: Parser Options+optionParser = Options+ <$> switch+ ( long "json"+ <> short 'j'+ <> help "Output patch in JSON."+ )+ <*> option fileP+ ( long "output"+ <> short 'o'+ <> metavar "OUTPUT"+ <> value Nothing+ )+ <*> argument fileP+ ( metavar "FROM"+ )+ <*> argument fileP+ ( metavar "TO"+ )+ where+ fileP = do+ s <- readerAsk+ return $ case s of+ "-" -> Nothing+ _ -> Just s++jsonFile :: Handle -> IO Value+jsonFile fp = do+ s <- BS.hGetContents fp+ case decode (BSL.fromStrict s)of+ Nothing -> error "Could not parse as JSON"+ Just v -> return v++run :: Options -> IO ()+run opt = bracket (load opt) close process+ where+ openr :: Maybe FilePath -> IO Handle+ openr Nothing = return stdin+ openr (Just p) = openFile p ReadMode++ openw :: Maybe FilePath -> IO Handle+ openw Nothing = return stdout+ openw (Just p) = openFile p WriteMode++ load :: Options -> IO Configuration+ load Options{..} =+ Configuration+ <$> pure optionJSON+ <*> openw optionOut+ <*> openr optionFrom+ <*> openr optionTo++ close :: Configuration -> IO ()+ close Configuration{..} = do+ hClose cfgOut+ hClose cfgFrom+ hClose cfgTo++process :: Configuration -> IO ()+process Configuration{..} = do+ json_from <- jsonFile cfgFrom+ json_to <- jsonFile cfgTo+ let p = diff json_from json_to+ if cfgJSON+ then BS.hPutStrLn cfgOut . BSL.toStrict . encode $ p+ else T.hPutStrLn cfgOut . formatPatch $ p++main :: IO ()+main = execParser opts >>= run+ where+ opts = info (helper <*> optionParser)+ ( fullDesc+ <> progDesc "Generate a patch between two JSON documents.")
+ src/patch.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE RecordWildCards #-}++module Main where++import Control.Applicative+import Control.Exception+import Data.Aeson+import Data.Aeson.Diff+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Monoid+import Options.Applicative hiding (Success)+import Options.Applicative.Types hiding (Success)+import System.IO++type File = Maybe FilePath++-- | Command-line options.+data Options = Options+ { optionJSON :: Bool -- ^ Patch is JSON?+ , optionOut :: File -- ^ JSON destination+ , optionPatch :: File -- ^ Patch input+ , optionFrom :: File -- ^ JSON source+ }++data Configuration = Configuration+ { cfgJSON :: Bool+ , cfgOut :: Handle+ , cfgPatch :: Handle+ , cfgFrom :: Handle+ }++optionParser :: Parser Options+optionParser = Options+ <$> switch+ ( long "json"+ <> short 'j'+ <> help "Patch is in JSON format."+ )+ <*> option fileP+ ( long "output"+ <> short 'o'+ <> metavar "OUTPUT"+ <> help "Destination for patched JSON."+ <> value Nothing+ )+ <*> argument fileP+ ( metavar "PATCH"+ <> help "Patch to apply."+ )+ <*> argument fileP+ ( metavar "FROM"+ <> help "JSON file to patch."+ )+ where+ fileP = do+ s <- readerAsk+ return $ case s of+ "-" -> Nothing+ _ -> Just s++jsonRead :: Handle -> IO Value+jsonRead fp = do+ s <- BS.hGetContents fp+ case decode (BSL.fromStrict s)of+ Nothing -> error "Could not parse as JSON"+ Just v -> return v++run :: Options -> IO ()+run opt = bracket (load opt) close process+ where+ openr :: Maybe FilePath -> IO Handle+ openr Nothing = return stdin+ openr (Just p) = openFile p ReadMode++ openw :: Maybe FilePath -> IO Handle+ openw Nothing = return stdout+ openw (Just p) = openFile p WriteMode++ load :: Options -> IO Configuration+ load Options{..} =+ Configuration+ <$> pure optionJSON+ <*> openw optionOut+ <*> openr optionPatch+ <*> openr optionFrom++ close :: Configuration -> IO ()+ close Configuration{..} = do+ hClose cfgPatch+ hClose cfgFrom+ hClose cfgOut++process :: Configuration -> IO ()+process Configuration{..} = do+ json_patch <- if cfgJSON+ then jsonRead cfgPatch+ else error "Patch must be in JSON format. Sorry :-("+ json_from <- jsonRead cfgFrom+ case fromJSON json_patch of+ Error e -> error e+ Success p -> BS.hPutStrLn cfgOut . BSL.toStrict . encode+ $ patch p json_from++main :: IO ()+main = execParser opts >>= run+ where+ opts = info (helper <*> optionParser)+ ( fullDesc+ <> progDesc "Generate a patch between two JSON documents.")
+ test/properties.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Control.Monad+import Data.Aeson+import Data.HashMap.Strict (HashMap)+import Data.Monoid+import Data.Text (Text)+import qualified Data.Vector as V+import System.Exit+import Test.QuickCheck+import Test.QuickCheck.Instances ()++import Data.Aeson.Diff++instance Arbitrary Value where+ arbitrary = elements+ [ Null+ , Bool True+ , Number 123+ , String "boo"+ , Array . V.fromList $ [String "123", Number 123]+ ]++-- | Patch extracted from identical documents should be mempty.+prop_diff_id+ :: Value+ -> Bool+prop_diff_id v = diff v v == mempty++-- | Extracting and applying a patch is an identity.+prop_diff_apply+ :: Value+ -> Value+ -> Bool+prop_diff_apply f t = t == patch (diff f t) f++-- | Extract and apply a patch (specialised to JSON arrays).+prop_diff_arrays+ :: [Value]+ -> [Value]+ -> Bool+prop_diff_arrays v1 v2 = prop_diff_apply (Array . V.fromList $ v1) (Array . V.fromList $ v2)++-- | Extract and apply a patch (specialised to JSON objects).+prop_diff_objects+ :: HashMap Text Value+ -> HashMap Text Value+ -> Bool+prop_diff_objects m1 m2 = prop_diff_apply (Object m1) (Object m2)++--+-- 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