Generate patches with local pure moves

.gitignore

@@ -1,2 +1,2 @@
 .stack-work
-
+/*.lock

aeson-diff.cabal

@@ -19,10 +19,11 @@ cabal-version:       >=1.10
 extra-source-files:  README.md
                    , CHANGELOG.md
                    , stack.yaml
+                   , test/data/diff-cases/*.json
+                   , test/data/patch-cases/*.json
+                   , test/data/patch-cases/*.txt
                    , test/data/rfc6902/*.json
                    , test/data/rfc6902/*.txt
-                   , test/data/cases/*.json
-                   , test/data/cases/*.txt
 
 source-repository      HEAD
   type: git
@@ -84,11 +85,29 @@ test-suite             properties
                      , unordered-containers
                      , vector
 
-test-suite             examples
+test-suite             patch-examples
   default-language:    Haskell2010
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
-  main-is:             examples.hs
+  main-is:             patch-examples.hs
+  build-depends:       base
+                     , Glob
+                     , QuickCheck
+                     , aeson
+                     , aeson-diff
+                     , bytestring
+                     , directory
+                     , filepath
+                     , quickcheck-instances
+                     , text
+                     , unordered-containers
+                     , vector
+
+test-suite             diff-examples
+  default-language:    Haskell2010
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             diff-examples.hs
   build-depends:       base
                      , Glob
                      , QuickCheck

lib/Data/Aeson/Diff.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
-
+{-# LANGUAGE ViewPatterns      #-}
 -- | Description: Extract and apply patches on JSON documents.
 --
 -- This module implements data types and operations to represent the
@@ -19,6 +19,7 @@ module Data.Aeson.Diff (
     diff',
     patch,
     applyOperation,
+    renderDiff,
 ) where
 
 import           Control.Applicative
@@ -31,12 +32,15 @@ import           Data.Foldable              (foldlM)
 import           Data.Hashable
 import           Data.HashMap.Strict        (HashMap)
 import qualified Data.HashMap.Strict        as HM
+import qualified Data.HashSet               as HS
 import           Data.List                  (groupBy, intercalate)
 import           Data.Maybe
 import           Data.Monoid
 import           Data.Scientific
 import           Data.Text                  (Text)
 import qualified Data.Text                  as T
+import qualified Data.Text.IO               as T
+import qualified Data.Text.Encoding         as TE
 import           Data.Vector                (Vector)
 import qualified Data.Vector                as V
 import           Data.Vector.Distance
@@ -84,8 +88,11 @@ ins cfg p v = [Add p v]
 del :: Config -> Pointer -> Value -> [Operation]
 del Config{..} p v =
   if configTstBeforeRem
-  then [Tst p v, Rem p]
-  else [Rem p]
+  then [Tst p v, Rem p (Just v)]
+  else [Rem p (Just v)]
+
+mov :: Config -> Pointer -> Pointer -> [Operation]
+mov _ t f = [Mov t f]
 
 -- | Construct a patch which changes 'Rep' operation.
 rep :: Config -> Pointer -> Value -> [Operation]
@@ -128,38 +135,41 @@ diff' cfg@Config{..} v v' = Patch (worker mempty v v')
         -- For values of different types, replace v1 with v2.
         _                      -> rep cfg p v2
 
+    objectFindDel :: Value -> [(Text, Value)] -> Maybe (Text, [(Text, Value)])
+    objectFindDel _ [] = Nothing
+    objectFindDel needle (d@(k, straw) : ds)
+        | needle == straw = Just (k, ds)
+        | otherwise       =  (\(k, t) -> (k, d:t)) <$> objectFindDel needle ds
+    objectMoves :: ([Operation], [Operation], [(Text, Value)]) -> Text -> Value -> ([Operation], [Operation], [(Text, Value)])
+    objectMoves (as, ms, del) k v =
+        case objectFindDel v del of
+            Nothing          -> (ins cfg (Pointer [OKey k]) v <> as, ms, del)
+            Just (k2, del')  -> (as, mov cfg (Pointer [OKey k]) (Pointer [OKey k2]) <> ms, del')
+
     -- 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
-            -- 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))
-                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))
-                ins_keys
+        let k1 = HM.keysSet o1
+            k2 = HM.keysSet o2
+            -- Changed keys
+            dels' = HM.filterWithKey (\k v -> not $ k `HS.member` k2) o1
+            adds' = HM.filterWithKey (\k v -> not $ k `HS.member` k1) o2
+            chg_keys = HS.intersection k1 k2
+            (insertions, moves, deletions') = HM.foldlWithKey' objectMoves ([], [], HM.toList dels') adds'
+            deletions = concatMap (\(k,v) -> del cfg (Pointer [OKey k]) v) deletions'
             -- 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))
-                chg_keys
-        in modifyPointer (path <>) <$> (deletions <> insertions <> changes)
+                (HS.toList chg_keys)
+        in modifyPointer (path <>) <$> (insertions <> deletions <> moves <> changes)
 
     -- Use an adaption of the Wagner-Fischer algorithm to find the shortest
     -- sequence of changes between two JSON arrays.
     workArray :: Pointer -> Array -> Array -> [Operation]
-    workArray path ss tt = fmap (modifyPointer (path <>)) . snd . fmap concat $ leastChanges params ss tt
+    workArray path ss tt = rewriteLocalMoves . fmap (modifyPointer (path <>)) . snd . fmap concat $ leastChanges params ss tt
       where
         params :: Params Value [Operation] (Sum Int)
         params = Params{..}
@@ -206,6 +216,24 @@ diff' cfg@Config{..} v v' = Patch (worker mempty v v')
             | otherwise        = 0
         pos Tst{changePointer=Pointer path} = 0
 
+-- | Replace add/remove pairs with moves.
+--
+-- This only works for sibling keys and for values that are otherwise unmodified.
+-- And it's inefficient to boot. 
+rewriteLocalMoves :: [Operation] -> [Operation]
+rewriteLocalMoves ops = ops
+
+renderDiff :: Operation -> Text
+renderDiff (Add (formatPointer -> p) (formatValue -> v)) = T.unwords ["ADD", p, v]
+renderDiff (Cpy (formatPointer -> p1) (formatPointer -> p2)) = T.unwords ["COPY", p1, p2]
+renderDiff (Mov (formatPointer -> p1) (formatPointer -> p2)) = T.unwords ["MOVE", p1, p2]
+renderDiff (Rem (formatPointer -> p) _) = T.unwords ["REMOVE", p]
+renderDiff (Rep (formatPointer -> p) (formatValue -> v)) = T.unwords ["REPLACE", p, v]
+renderDiff (Tst (formatPointer -> p) (formatValue -> v)) = T.unwords ["TEST", p, v]
+
+formatValue :: Value -> Text
+formatValue = TE.decodeUtf8 . BS.toStrict . encode
+
 -- * Patching
 
 -- | Apply a patch to a JSON document.
@@ -223,7 +251,7 @@ applyOperation
     -> Result Value
 applyOperation op json = case op of
     Add path v'   -> applyAdd path v' json
-    Rem path      -> applyRem path    json
+    Rem path _    -> applyRem path    json
     Rep path v'   -> applyRep path v' json
     Tst path v    -> applyTst path v  json
     Cpy path from -> applyCpy path from json

lib/Data/Aeson/Patch.hs

@@ -64,7 +64,7 @@ data Operation
     -- ^ http://tools.ietf.org/html/rfc6902#section-4.5
     | Mov { changePointer :: Pointer, fromPointer :: Pointer }
     -- ^ http://tools.ietf.org/html/rfc6902#section-4.4
-    | Rem { changePointer :: Pointer }
+    | Rem { changePointer :: Pointer, deletedValue :: Maybe Value }
     -- ^ http://tools.ietf.org/html/rfc6902#section-4.2
     | Rep { changePointer :: Pointer, changeValue :: Value }
     -- ^ http://tools.ietf.org/html/rfc6902#section-4.3
@@ -88,7 +88,7 @@ instance ToJSON Operation where
         , "path" .= p
         , "from" .= f
         ]
-    toJSON (Rem p) = object
+    toJSON (Rem p _) = object
         [ ("op", "remove")
         , "path" .= p
         ]
@@ -110,7 +110,7 @@ instance FromJSON Operation where
             =   (op v "add"     *> (Add <$> v .: "path" <*> v .: "value"))
             <|> (op v "copy"    *> (Cpy <$> v .: "path" <*> v .: "from"))
             <|> (op v "move"    *> (Mov <$> v .: "path" <*> v .: "from"))
-            <|> (op v "remove"  *> (Rem <$> v .: "path"))
+            <|> (op v "remove"  *> (Rem <$> v .: "path" <*> (pure Nothing)))
             <|> (op v "replace" *> (Rep <$> v .: "path" <*> v .: "value"))
             <|> (op v "test"    *> (Tst <$> v .: "path" <*> v .: "value"))
             <|> fail ("Expected a JSON patch operation, encountered: " <> BS.unpack (encode o))

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: 523700
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/7.yaml
+    sha256: 8e3f3c894be74d71fa4bf085e0a8baae7e4d7622d07ea31a52736b80f8b9bb1a
+  original: lts-14.7

test/data/diff-cases/c1-a.json

@@ -0,0 +1 @@
+["a", "b", "c"]

test/data/diff-cases/c1-b.json

@@ -0,0 +1 @@
+["a", "c", "b"]

test/data/diff-cases/c1-patch.json

@@ -0,0 +1,7 @@
+[
+  {
+    "op": "move",
+    "from": "/1",
+    "path": "/2"
+  }
+]

test/data/diff-cases/c2-a.json

@@ -0,0 +1,5 @@
+{
+  "a": 1,
+  "b": 2,
+  "c": 3
+}

test/data/diff-cases/c2-b.json

@@ -0,0 +1,5 @@
+{
+  "a": 1,
+  "c": 3,
+  "d": 2
+}

test/data/diff-cases/c2-patch.json

@@ -0,0 +1,7 @@
+[
+  {
+    "op": "move",
+    "from": "/b",
+    "path": "/d"
+  }
+]

test/diff-examples.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE TupleSections #-}
+
+-- | Test examples from RFC 6902 sections A.1 to A.16.
+
+module Main where
+
+import           Control.Applicative
+import           Control.Exception
+import           Control.Monad
+import           Data.Aeson
+import           Data.Aeson.Diff
+import qualified Data.ByteString            as BS
+import qualified Data.ByteString.Char8      as BC
+import qualified Data.ByteString.Lazy.Char8 as BL
+import           Data.Char
+import           Data.Either
+import           Data.Functor
+import           Data.List                  (isInfixOf, nub)
+import           Data.Maybe
+import           Data.Monoid
+import           System.Directory
+import           System.Environment
+import           System.Exit
+import           System.FilePath
+import           System.FilePath.Glob
+
+roots :: [FilePath]
+roots = ["test/data/diff-cases"]
+
+globPattern :: FilePath
+globPattern = "*.*"
+
+derp :: String -> a
+derp msg = throw (AssertionFailed $ " " <> msg)
+
+readOriginal :: FilePath -> FilePath -> IO Value
+readOriginal root name = do
+    let file = root </> name <> "-a.json"
+    doc <- eitherDecodeStrict <$> BS.readFile file
+
+    return $ either (\e -> derp $ "Could not decode original: " <> e) id doc
+
+readChanged :: FilePath -> FilePath -> IO Value
+readChanged root name = do
+    let file = root </> name <> "-b.json"
+    doc <- eitherDecodeStrict <$> BS.readFile file
+
+    return $ either (\e -> derp $ "Could not decode changed: " <> e) id doc
+
+readPatch :: FilePath -> FilePath -> IO Patch
+readPatch root name = do
+    let file = root </> name <> "-patch.json"
+    doc <- eitherDecodeStrict <$> BS.readFile file
+
+    return $ either (\e -> derp $ "Could not decode patch: " <> e) id doc
+
+readExample :: FilePath -> FilePath -> IO (Value, Value, Patch)
+readExample root name =
+    (,,) <$> readOriginal root name
+         <*> readChanged root name
+         <*> readPatch root name
+
+-- | Check example and, if it fails, return an error message.
+runExample :: (Value, Value, Patch) -> Maybe String
+runExample (doc, changed, res) =
+    case diff doc changed of
+        dest | dest == res -> success "Result matches target"
+             | otherwise   -> failure ("Result patch did not match: " <> BL.unpack (encode dest))
+  where
+    success n = Nothing
+    failure n = Just ("Test Fails - " <> n)
+
+testExample :: FilePath -> FilePath -> IO (Maybe String)
+testExample root name = do
+    r <- try (runExample <$> readExample root name)
+    return $ either err id r
+  where
+    err :: AssertionFailed -> Maybe String
+    err e = Just ("Error: " <> show e)
+
+runSuite :: FilePath -> IO [(FilePath, Maybe String)]
+runSuite root = do
+    -- Gather directories in test/data
+    let p = simplify (compile globPattern)
+    examples <- nub . fmap (takeWhile (/= '-')) . filter (match p) <$> getDirectoryContents root
+    -- Test each of them
+    mapM (\nom -> (nom,) <$> testExample root nom) examples
+
+main :: IO ()
+main = do
+    args <- getArgs
+    results <- concat <$> mapM runSuite (if null args then roots else args)
+    mapM_ display results
+    -- Failure.
+    when (any (isJust . snd) results)
+        exitFailure
+  where
+    display :: (FilePath, Maybe String) -> IO ()
+    display (name, Nothing) =
+        putStrLn $ "SUCCESS: " <> name
+    display (name, Just err) =
+        putStrLn $ "FAILURE: " <> name <> ": " <> err

test/examples.hs → test/patch-examples.hs

@@ -25,7 +25,7 @@ import           System.FilePath
 import           System.FilePath.Glob
 
 roots :: [FilePath]
-roots = ["test/data/rfc6902", "test/data/cases"]
+roots = ["test/data/rfc6902", "test/data/patch-cases"]
 
 globPattern :: FilePath
 globPattern = "*.*"
@@ -40,7 +40,6 @@ readDocument root name = do
 
     return $ either (\e -> derp $ "Could not decode document: " <> e) id doc
 
-
 readPatch :: FilePath -> FilePath -> IO (Either String Patch)
 readPatch root name = do
     let file = root </> name <> "-patch.json"
@@ -66,7 +65,7 @@ readResult root name = do
     handle :: IOException -> IO (Maybe a)
     handle e = return Nothing
 
-readExample :: FilePath -> FilePath -> IO (Value, Either String Patch, Either String Value)
+readExample :: FilePath -> FilePath -> IO (Value, Either String Patch , Either String Value)
 readExample root name =
     (,,) <$> readDocument root name
          <*> readPatch root name