diff --git a/aeson-diff.cabal b/aeson-diff.cabal index 0a9b71e..bf98590 100644 --- a/aeson-diff.cabal +++ b/aeson-diff.cabal @@ -34,7 +34,8 @@ library exposed-modules: Data.Aeson.Diff , Data.Aeson.Patch , Data.Aeson.Pointer - build-depends: base >=4.9 && <4.16 + , Data.Aeson.Diff.Util + build-depends: base , aeson , bytestring >= 0.10 , edit-distance-vector diff --git a/lib/Data/Aeson/Diff.hs b/lib/Data/Aeson/Diff.hs index 55f006a..044d1ea 100644 --- a/lib/Data/Aeson/Diff.hs +++ b/lib/Data/Aeson/Diff.hs @@ -1,6 +1,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} -- | Description: Extract and apply patches on JSON documents. -- @@ -24,13 +26,12 @@ module Data.Aeson.Diff ( import Control.Applicative import Control.Monad import Control.Monad.Error.Class -import Data.Aeson +import Data.Aeson hiding (Key) import Data.Aeson.Types (modifyFailure, typeMismatch) import qualified Data.ByteString.Lazy.Char8 as BS import Data.Foldable (foldlM) -import Data.Hashable import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM +import Data.Hashable import Data.List (groupBy, intercalate) import Data.Maybe import Data.Monoid @@ -41,9 +42,18 @@ import Data.Vector (Vector) import qualified Data.Vector as V import Data.Vector.Distance +import Data.Aeson.Diff.Util import Data.Aeson.Patch import Data.Aeson.Pointer +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as A +import qualified Data.Aeson.KeyMap as HM +#else +import qualified Data.HashMap.Strict as HM +#endif + + -- * Configuration -- | Configuration for the diff algorithm. @@ -131,28 +141,28 @@ diff' cfg@Config{..} v v' = Patch (worker mempty v v') -- Walk the keys in two objects, producing a 'Patch'. workObject :: Pointer -> Object -> Object -> [Operation] workObject path o1 o2 = - let k1 = HM.keys o1 - k2 = HM.keys o2 + let k1 = textKeys o1 + k2 = textKeys o2 -- Deletions del_keys :: [Text] del_keys = filter (not . (`elem` k2)) k1 deletions :: [Operation] deletions = concatMap - (\k -> del cfg (Pointer [OKey k]) (fromJust $ HM.lookup k o1)) + (\k -> del cfg (Pointer [OKey k]) (fromJust $ aesonLookup k o1)) del_keys -- Insertions ins_keys = filter (not . (`elem` k1)) k2 insertions :: [Operation] insertions = concatMap - (\k -> ins cfg (Pointer [OKey k]) (fromJust $ HM.lookup k o2)) + (\k -> ins cfg (Pointer [OKey k]) (fromJust $ aesonLookup k o2)) ins_keys -- Changes chg_keys = filter (`elem` k2) k1 changes :: [Operation] changes = concatMap (\k -> worker (Pointer [OKey k]) - (fromJust $ HM.lookup k o1) - (fromJust $ HM.lookup k o2)) + (fromJust $ aesonLookup k o1) + (fromJust $ aesonLookup k o2)) chg_keys in modifyPointer (path <>) <$> (deletions <> insertions <> changes) @@ -164,9 +174,9 @@ diff' cfg@Config{..} v v' = Patch (worker mempty v v') params :: Params Value [Operation] (Sum Int) params = Params{..} equivalent = (==) - delete i = del cfg (Pointer [AKey i]) - insert i = ins cfg (Pointer [AKey i]) - substitute i = worker (Pointer [AKey i]) + delete i = del cfg (Pointer [OKey (tShow i)]) + insert i = ins cfg (Pointer [OKey (tShow i)]) + substitute i = worker (Pointer [OKey (tShow i)]) cost = Sum . sum . fmap operationCost -- Position is advanced by grouping operations with same "head" index: -- + groups of many operations advance one @@ -244,24 +254,22 @@ applyAdd pointer = go pointer where go (Pointer []) val _ = return val - go (Pointer [AKey i]) v' (Array v) = - let fn :: Maybe Value -> Result (Maybe Value) - fn _ = return (Just v') - in return (Array $ vInsert i v' v) - go (Pointer (AKey i : path)) v' (Array v) = - let fn :: Maybe Value -> Result (Maybe Value) - fn Nothing = cannot "insert" "array" i pointer - fn (Just d) = Just <$> go (Pointer path) v' d - in Array <$> vModify i fn v go (Pointer [OKey n]) v' (Object m) = - return . Object $ HM.insert n v' m + return . Object $ aesonInsert n v' m go (Pointer (OKey n : path)) v' (Object o) = let fn :: Maybe Value -> Result (Maybe Value) fn Nothing = cannot "insert" "object" n pointer fn (Just d) = Just <$> go (Pointer path) v' d in Object <$> hmModify n fn o go (Pointer (OKey n : path)) v' array@(Array v) - | n == "-" = go (Pointer (AKey (V.length v) : path)) v' array + | n == "-" = go (Pointer (OKey (tShow $ V.length v) : path)) v' array + go (Pointer [OKey (readIntegral -> Just i)]) v' (Array v) = + return (Array $ vInsert i v' v) + go (Pointer (OKey (readIntegral -> Just i) : path)) v' (Array v) = + let fn :: Maybe Value -> Result (Maybe Value) + fn Nothing = cannot "insert" "array" i pointer + fn (Just d) = Just <$> go (Pointer path) v' d + in Array <$> vModify i fn v go path _ v = pointerFailure path v -- | Apply a 'Rem' operation to a document. @@ -273,16 +281,6 @@ applyRem :: Pointer -> Value -> Result Value applyRem from@(Pointer path) = go path where go [] _ = return Null - go [AKey i] d@(Array v) = - let fn :: Maybe Value -> Result (Maybe Value) - fn Nothing = cannot "delete" "array" i from - fn (Just v) = return Nothing - in Array <$> vModify i fn v - go (AKey i : path) (Array v) = - let fn :: Maybe Value -> Result (Maybe Value) - fn Nothing = cannot "traverse" "array" i from - fn (Just o) = Just <$> go path o - in Array <$> vModify i fn v go [OKey n] (Object m) = let fn :: Maybe Value -> Result (Maybe Value) fn Nothing = cannot "delete" "object" n from @@ -295,7 +293,17 @@ applyRem from@(Pointer path) = go path in Object <$> hmModify n fn m -- Dodgy hack for "-" key which means "the end of the array". go (OKey n : path) array@(Array v) - | n == "-" = go (AKey (V.length v) : path) array + | n == "-" = go (OKey (tShow $ V.length v) : path) array + go [OKey (readIntegral -> Just i)] d@(Array v) = + let fn :: Maybe Value -> Result (Maybe Value) + fn Nothing = cannot "delete" "array" i from + fn (Just v) = return Nothing + in Array <$> vModify i fn v + go (OKey (readIntegral -> Just i) : path) (Array v) = + let fn :: Maybe Value -> Result (Maybe Value) + fn Nothing = cannot "traverse" "array" i from + fn (Just o) = Just <$> go path o + in Array <$> vModify i fn v -- Type mismatch: clearly the thing we're deleting isn't here. go path value = pointerFailure from value @@ -392,15 +400,22 @@ vModify i f v = -- function returns 'Nothing', the key and value are deleted from the map; -- otherwise the value replaces the existing value in the returned map. hmModify +#if MIN_VERSION_aeson(2,0,0) + :: Text + -> (Maybe v -> Result (Maybe v)) + -> HM.KeyMap v + -> Result (HM.KeyMap v) +#else :: (Eq k, Hashable k) => k -> (Maybe v -> Result (Maybe v)) -> HashMap k v -> Result (HashMap k v) -hmModify k f m = case f (HM.lookup k m) of +#endif +hmModify k f m = case f (aesonLookup k m) of Error e -> Error e - Success Nothing -> return $ HM.delete k m - Success (Just v) -> return $ HM.insert k v m + Success Nothing -> return $ aesonDelete k m + Success (Just v) -> return $ aesonInsert k v m -- | Report an error about being able to use a pointer key. cannot diff --git a/lib/Data/Aeson/Diff/Util.hs b/lib/Data/Aeson/Diff/Util.hs new file mode 100644 index 0000000..bf03a9f --- /dev/null +++ b/lib/Data/Aeson/Diff/Util.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} + +module Data.Aeson.Diff.Util where + +import qualified Data.Aeson as A +import Data.Text + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as A +import qualified Data.Aeson.KeyMap as HM +#else +import Data.Hashable +import qualified Data.HashMap.Strict as HM +#endif + + +textKeys :: A.Object -> [Text] +#if MIN_VERSION_aeson(2,0,0) +textKeys = fmap A.toText . HM.keys +#else +textKeys = HM.keys +#endif + +#if MIN_VERSION_aeson(2,0,0) +aesonLookup :: Text -> HM.KeyMap v -> Maybe v +aesonLookup = HM.lookup . A.fromText +#else +aesonLookup :: (Eq k, Hashable k) => k -> HM.HashMap k v -> Maybe v +aesonLookup = HM.lookup +#endif + +#if MIN_VERSION_aeson(2,0,0) +aesonInsert :: Text -> v -> HM.KeyMap v -> HM.KeyMap v +aesonInsert t = HM.insert (A.fromText t) +#else +aesonInsert :: (Eq k, Hashable k) => k -> v -> HM.HashMap k v -> HM.HashMap k v +aesonInsert = HM.insert +#endif + +#if MIN_VERSION_aeson(2,0,0) +aesonDelete :: Text -> HM.KeyMap v -> HM.KeyMap v +aesonDelete t = HM.delete (A.fromText t) +#else +aesonDelete :: (Eq k, Hashable k) => k -> HM.HashMap k v -> HM.HashMap k v +aesonDelete = HM.delete +#endif + +#if MIN_VERSION_aeson(2,0,0) +aesonToList :: HM.KeyMap v -> [(A.Key, v)] +aesonToList = HM.toList +#else +aesonToList :: HM.HashMap k v -> [(k, v)] +aesonToList = HM.toList +#endif diff --git a/lib/Data/Aeson/Pointer.hs b/lib/Data/Aeson/Pointer.hs index 6e54758..fb5eed8 100644 --- a/lib/Data/Aeson/Pointer.hs +++ b/lib/Data/Aeson/Pointer.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} -- | Description: JSON Pointers as described in RFC 6901. module Data.Aeson.Pointer ( Pointer(..), @@ -12,44 +13,49 @@ module Data.Aeson.Pointer ( -- * Using pointers get, pointerFailure, + -- * Util + readIntegral, + tShow ) where import Control.Applicative -import Data.Aeson -import Data.Aeson.Types +import qualified Data.Aeson as A +import Data.Aeson hiding (Key) +import Data.Aeson.Types hiding (Key) import qualified Data.ByteString.Lazy.Char8 as BS import Data.Char (isNumber) -import qualified Data.HashMap.Strict as HM import Data.Monoid import Data.Scientific import Data.Semigroup (Semigroup) import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Read (decimal) import qualified Data.Vector as V import GHC.Generics (Generic) +import Text.Read (readMaybe) + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as A +import qualified Data.Aeson.KeyMap as HM +#else +import qualified Data.HashMap.Strict as HM +#endif -- * Patch components -- | Path components to traverse a single layer of a JSON document. -data Key - = OKey Text -- ^ Traverse a 'Value' with an 'Object' constructor. - | AKey Int -- ^ Traverse a 'Value' with an 'Array' constructor. +data Key = OKey Text deriving (Eq, Ord, Show, Generic) 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." + parseJSON _ = fail "A key element must be a string." formatKey :: Key -> Text -formatKey (AKey i) = T.pack (show i) formatKey (OKey t) = T.concatMap esc t where esc :: Char -> Text @@ -78,7 +84,7 @@ newtype Pointer = Pointer { pointerPath :: Path } -- "/ " -- >>> formatPointer (Pointer [OKey "foo"]) -- "/foo" --- >>> formatPointer (Pointer [OKey "foo", AKey 0]) +-- >>> formatPointer (Pointer [OKey "foo", OKey "0"]) -- "/foo/0" -- >>> formatPointer (Pointer [OKey "a/b"]) -- "/a~1b" @@ -113,8 +119,7 @@ parsePointer t let l = T.split (== '~') t in T.concat $ take 1 l <> fmap step (tail l) key t - | T.null t = fail "JSON components must not be empty." - | T.all isNumber t = return (AKey (read $ T.unpack t)) + | T.null t = return $ OKey "" | otherwise = return $ OKey (unesc t) instance ToJSON Pointer where @@ -130,10 +135,15 @@ instance FromJSON Pointer where -- | Follow a 'Pointer' through a JSON document as described in RFC 6901. get :: Pointer -> Value -> Result Value get (Pointer []) v = return v -get (Pointer (AKey i : path)) (Array v) = - maybe (fail "") return (v V.!? i) >>= get (Pointer path) +get (Pointer (OKey k : path)) (Array v) = case readIntegral k of + Just i -> maybe (fail "") return (v V.!? i) >>= get (Pointer path) + Nothing -> Error "Expected a numeric pointer for array." get (Pointer (OKey n : path)) (Object v) = +#if MIN_VERSION_aeson(2,0,0) + maybe (fail "") return (HM.lookup (A.fromText n) v) >>= get (Pointer path) +#else maybe (fail "") return (HM.lookup n v) >>= get (Pointer path) +#endif get pointer value = pointerFailure pointer value -- | Report an error while following a pointer. @@ -144,10 +154,15 @@ pointerFailure (Pointer path@(key:_)) value = where doc = encode value pt = encode path - ty = case key of - (AKey _) -> "array" - (OKey _) -> "object" + ty = "object" + +readIntegral :: (Integral a, Read a) => Text -> Maybe a +readIntegral t = case decimal t of + Right (n, "") -> Just n + _ -> Nothing +tShow :: (Integral a, Show a) => a -> Text +tShow = T.pack . show -- $setup -- >>> :set -XOverloadedStrings diff --git a/stack.yaml b/stack.yaml index 7e560bc..35c5956 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,5 @@ -resolver: lts-14.7 +resolver: lts-19.7 +# resolver: nightly-2022-02-07 extra-deps: [] flags: {} extra-package-dbs: [] diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..8787e19 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 618884 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/7.yaml + sha256: 57d4ce67cc097fea2058446927987bc1f7408890e3a6df0da74e5e318f051c20 + original: lts-19.7 diff --git a/test/properties.hs b/test/properties.hs index af73ae6..b2c7b96 100644 --- a/test/properties.hs +++ b/test/properties.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -12,7 +13,6 @@ import Data.Aeson as A import qualified Data.ByteString.Lazy.Char8 as BL import Data.Functor import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM import Data.Monoid import Data.Text (Text) import qualified Data.Vector as V @@ -23,6 +23,14 @@ import Test.QuickCheck.Instances () import Data.Aeson.Diff import Data.Aeson.Patch +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as A +import qualified Data.Aeson.KeyMap as HM +#else +import qualified Data.HashMap.Strict as HM +#endif + + showIt :: Value -> String showIt = BL.unpack . encode @@ -57,6 +65,7 @@ instance Arbitrary (AnObject Value) where instance Arbitrary (AnArray Value) where arbitrary = AnArray . Array . V.fromList <$> scaleSize (`div` 2) arbitrary +#if !MIN_VERSION_aeson(2,0,0) instance Arbitrary Value where arbitrary = sized vals where vals :: Int -> Gen Value @@ -68,7 +77,7 @@ instance Arbitrary Value where , String <$> arbitrary ] | otherwise = wellformed <$> arbitrary - +#endif -- | Extracting and applying a patch is an identity. diffApply @@ -81,6 +90,16 @@ diffApply f t = error ("BAD PATCH\n" <> BL.unpack (encode p) <> "\n" <> result "" (BL.unpack . encode <$> patch p f)) +-- | Encoding a patch to and from JSON is an identity. +prop_encode_decode + :: Wellformed Value + -> Wellformed Value + -> Bool +prop_encode_decode (Wellformed f) (Wellformed t) = case A.eitherDecode $ A.encode p of + Left err -> error err + Right x -> x == p + where p = diff f t + result :: a -> A.Result a -> a result _ (A.Success a) = a result a _ = a