Remove OKey/AKey distinction and ensure ToJSON/FromJSON roundtrip

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

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

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

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

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: []

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