aeson-diff 1.0.0.0 → 1.0.0.1

raw patch · 17 files changed

+369/−303 lines, 17 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−4
• README.md +0/−3
• aeson-diff.cabal +4/−2
• lib/Data/Aeson/Diff.hs +99/−284
• lib/Data/Aeson/Patch.hs +107/−0
• lib/Data/Aeson/Pointer.hs +113/−0
• src/diff.hs +12/−4
• test/data/cases/case4-error.txt +1/−0
• test/data/cases/case4-original.json +3/−0
• test/data/cases/case4-patch.json +2/−0
• test/data/cases/case5-error.txt +1/−0
• test/data/cases/case5-original.json +2/−0
• test/data/cases/case5-patch.json +2/−0
• test/data/rfc6902/a12-error.txt +1/−1
• test/data/rfc6902/a15-error.txt +1/−1
• test/data/rfc6902/a9-error.txt +1/−1
• test/properties.hs +7/−3

@@ -1,11 +1,20 @@+aeson-diff 1.0.0.1++    * Remove the `patch'` function before anyone gets attached to it.++    * Remove the 'Value' which was carried by the 'Rem' operation constructor.++    * Move 'Pointer' and 'Patch' types and operations into separate modules.+ aeson-diff 1.0      * aeson-diff now supports the operations and patch format described in-      RFC6902.+      RFC 6902. -    * Patch application can fail. The patch function now returns in the-      'Result' monad from the aeson package. The new patch' function throws an-      exception instead.+    * The `patch` function now returns in the 'Result' monad from the aeson+      package.++    * Add a `patch'` function throws an exception instead.      * The command line applications no longer pretend to support a non-JSON       patch format.

@@ -81,9 +81,6 @@ - `diff :: Value -> Value -> Patch` examines source and target JSON `Value`s and constructs a new `Patch` describing the changes. -- `patch' :: Patch -> Value -> Result Value` applies the changes in a-`Path` to a JSON `Value`.- - `patch :: Patch -> Value -> Value` applies the changes in a `Patch` to a JSON `Value`. If an error results then an exception is thrown. 

@@ -1,5 +1,5 @@ name:                aeson-diff-version:             1.0.0.0+version:             1.0.0.1 synopsis:            Extract and apply patches to JSON documents. description:   .@@ -32,7 +32,9 @@   default-language:    Haskell2010   hs-source-dirs:      lib   exposed-modules:     Data.Aeson.Diff-  build-depends:       base >=4.5 && <4.9+                     , Data.Aeson.Patch+                     , Data.Aeson.Pointer+  build-depends:       base >=4.5 && <4.10                      , aeson                      , bytestring >= 0.10                      , edit-distance-vector

@@ -1,7 +1,6 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NamedFieldPuns             #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}  -- | Description: Extract and apply patches on JSON documents. --@@ -18,10 +17,7 @@     -- * Functions     diff,     patch,-    patch',     applyOperation,--    formatPatch, ) where  import           Control.Applicative@@ -30,7 +26,6 @@ import           Data.Aeson import           Data.Aeson.Types           (modifyFailure, typeMismatch) import qualified Data.ByteString.Lazy.Char8 as BS-import           Data.Char                  (isNumber) import           Data.Foldable              (foldlM) import           Data.Hashable import           Data.HashMap.Strict        (HashMap)@@ -46,116 +41,15 @@  import Data.Vector.Distance --- | Describes the changes between two JSON documents.-data Patch = Patch-  { patchOperations :: [Operation] }-  deriving (Eq)+import Data.Aeson.Patch+import Data.Aeson.Pointer -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) = toJSON ops--instance FromJSON Patch where-    parseJSON (Array v) = modifyFailure ("Could not parse patch: " <>) (Patch <$> mapM parseJSON (V.toList v))-    parseJSON v = modifyFailure ("Could not parse patch: " <> ) $ typeMismatch "Array" v--type Path = [Key]---- | Pointer to a location in a JSON document.------ Defined in RFC 6901 <http://tools.ietf.org/html/rfc6901>-newtype Pointer = Pointer { pointerPath :: Path }-  deriving (Eq, Show, Monoid)--pointerFailure :: Path -> Value -> Result a-pointerFailure [] value = Error ("UNPOSSIBLE!" <> show value)-pointerFailure path@(key:rest) value =-    fail . BS.unpack $ "Cannot follow pointer " <> pt <> ". Expected " <> ty <> " but got " <> doc-  where-    doc = encode value-    pt = encode (Pointer path)-    ty = case key of-           (AKey _) -> "array"-           (OKey _) -> "object"---- | An 'Operation' describes an atomic change to a JSON document.------ See RFC 6902 Section 4 <http://tools.ietf.org/html/rfc6902#section-4>.-data Operation-    = Add { changePointer :: Pointer, changeValue :: Value }-    -- ^ http://tools.ietf.org/html/rfc6902#section-4.1-    | Rem { changePointer :: Pointer, changeValue :: Value }-    -- ^ http://tools.ietf.org/html/rfc6902#section-4.2-    | Rep { changePointer :: Pointer, changeValue :: Value }-    -- ^ http://tools.ietf.org/html/rfc6902#section-4.3-    | Mov { changePointer :: Pointer, fromPointer :: Pointer }-    -- ^ http://tools.ietf.org/html/rfc6902#section-4.4-    | Cpy { changePointer :: Pointer, fromPointer :: Pointer }-    -- ^ http://tools.ietf.org/html/rfc6902#section-4.5-    | Tst { changePointer :: Pointer, changeValue :: Value }-    -- ^ http://tools.ietf.org/html/rfc6902#section-4.6-  deriving (Eq, Show)--instance ToJSON Operation where-    toJSON (Add p v) = object-        [ ("op", "add")-        , "path"  .= p-        , "value" .= v-        ]-    toJSON (Rem p v) = object-        [ ("op", "remove")-        , "path" .= p-        ]-    toJSON (Rep p v) = object-        [ ("op", "replace")-        , "path"  .= p-        , "value" .= v-        ]-    toJSON (Mov p f) = object-        [ ("op", "move")-        , "path" .= p-        , "from" .= f-        ]-    toJSON (Cpy p f) = object-        [ ("op", "copy")-        , "path" .= p-        , "from" .= f-        ]-    toJSON (Tst p v) = object-        [ ("op", "test")-        , "path" .= p-        , "value" .= v-        ]--instance FromJSON Operation where-    parseJSON o@(Object v)-        =   (op "add"     *> (Add <$> v .: "path" <*> v .: "value"))-        <|> (op "replace" *> (Rep <$> v .: "path" <*> v .: "value"))-        <|> (op "move"    *> (Mov <$> v .: "path" <*> v .: "from"))-        <|> (op "copy"    *> (Cpy <$> v .: "path" <*> v .: "from"))-        <|> (op "test"    *> (Tst <$> v .: "path" <*> v .: "value"))-        <|> (op "remove"  *> (Rem <$> v .: "path" <*> pure Null))-        <|> fail ("Expected a JSON patch operation, encountered: " <> BS.unpack (encode o))-      where-        op n = fixed v "op" (String n)-        fixed o n val = do-            v' <- o .: n-            if v' == val-              then return v'-              else mzero-    parseJSON v = typeMismatch "Operation" v- operationCost :: Operation -> Int operationCost op =     case op of       Add{} -> valueSize (changeValue op)-      Rem{} -> valueSize (changeValue op)+      Rem{} -> 1       Rep{} -> valueSize (changeValue op)       Mov{} -> 1       Cpy{} -> 1@@ -176,52 +70,7 @@           Cpy{} -> op { fromPointer = fn (fromPointer op) }           _     -> op --- | 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.-  deriving (Eq, Ord, Show) -instance ToJSON Pointer where-    toJSON (Pointer path) = String ("/" <> T.intercalate "/" (fmap fmt path))-        where-          esc :: Char -> Text-          esc '~' = "~0"-          esc '/' = "~1"-          esc c = T.singleton c-          fmt :: Key -> Text-          fmt (OKey t) = T.concatMap esc t-          fmt (AKey i) = T.pack (show i)--instance FromJSON Pointer where-    parseJSON (String t) = Pointer <$> mapM key (drop 1 $ T.splitOn "/" t)-        where-          step t-              | "0" `T.isPrefixOf` t = T.cons '~' (T.tail t)-              | "1" `T.isPrefixOf` t = T.cons '/' (T.tail t)-              | otherwise = T.cons '~' t-          unesc :: Text -> Text-          unesc 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))-              | otherwise        = return $ OKey (unesc t)-    parseJSON _ = fail "A JSON pointer must be a string."--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."- -- * Atomic patches  -- | Construct a patch with a single 'Add' operation.@@ -230,7 +79,7 @@  -- | Construct a patch with a single 'Rem' operation. del :: Path -> Value -> Patch-del p v = Patch [Rem (Pointer p) v]+del p v = Patch [Rem (Pointer p)]  -- | Construct a patch which changes 'Rep' operation. rep :: Path -> Value -> Patch@@ -271,7 +120,7 @@             -- Deletions             del_keys = filter (not . (`elem` k2)) k1             deletions = Patch $ fmap-                (\k -> Rem (Pointer [OKey k]) . fromJust $ HM.lookup k o1)+                (\k -> Rem (Pointer [OKey k]))                 del_keys             -- Insertions             ins_keys = filter (not . (`elem` k1)) k2@@ -295,7 +144,7 @@         params :: Params Value [Operation] (Sum Int)         params = Params{..}         equivalent = (==)-        delete i v = [Rem (Pointer [AKey i]) v]+        delete i v = [Rem (Pointer [AKey i])]         insert i v = [Add (Pointer [AKey i]) v]         substitute i v v' =             let p = [AKey i]@@ -341,15 +190,6 @@         pos Tst{changePointer=Pointer path} = 0  -- | Apply a patch to a JSON document.------ If the patch cannot be cleanly applied an 'error' is thrown.-patch' :: Patch -> Value -> Value-patch' p d =-    case patch p d of-      Error e -> error $ "Failed to apply patch: " <> e <> "\n" <> BS.unpack (encode p)-      Success v -> v---- | Apply a patch to a JSON document. patch     :: Patch     -> Value@@ -362,15 +202,15 @@     :: Operation     -> Value     -> Result Value-applyOperation op j = case op of-    Add (Pointer path) v' -> applyAdd path v' j-    Rem (Pointer path) _  -> applyRem path    j-    Rep (Pointer path) v' -> applyRep path v' j-    Mov (Pointer path) (Pointer from) -> do-        v' <- get from j-        applyRem from j >>= applyAdd path v'-    Cpy (Pointer path) (Pointer from) -> applyCpy path from j-    Tst (Pointer path) v  -> applyTst path v j+applyOperation op json = case op of+    Add path v'   -> applyAdd path v' 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+    Mov path from -> do+        v' <- get from json+        applyRem from json >>= applyAdd path v'  -- | Apply an 'Add' operation to a document. --@@ -380,74 +220,78 @@ -- - A single 'OKey' inserts or replaces the corresponding member in an object. -- - A single 'AKey' inserts at the corresponding location. -- - Longer 'Paths' traverse if they can and fail otherwise.-applyAdd :: Path -> Value -> Value -> Result Value-applyAdd [] val _ =-    return val-applyAdd [AKey i] v' (Array v) =-    let fn :: Maybe Value -> Result (Maybe Value)-        fn _ = return (Just v')-    in return (Array $ vInsert i v' v)-applyAdd (AKey i : path) v' (Array v) =-    let fn :: Maybe Value -> Result (Maybe Value)-        fn Nothing = Error "Cannot insert beneath missing array index."-        fn (Just d) = Just <$> applyAdd path v' d-    in Array <$> vModify i fn v-applyAdd [OKey n] v' (Object m) =-    return . Object $ HM.insert n v' m-applyAdd (OKey n : path) v' (Object o) =-    let fn :: Maybe Value -> Result (Maybe Value)-        fn Nothing = Error ("Cannot insert beneath missing object index: " <> show n)-        fn (Just d) = Just <$> applyAdd path v' d-    in Object <$> hmModify n fn o-applyAdd (OKey n : path) v' array@(Array v)-    | n == "-" = applyAdd (AKey (V.length v) : path) v' array-applyAdd path _ v = pointerFailure path v+applyAdd :: Pointer -> Value -> Value -> Result Value+applyAdd from@(Pointer path) = go path+  where+    go [] val _ =+        return val+    go [AKey i] v' (Array v) =+        let fn :: Maybe Value -> Result (Maybe Value)+            fn _ = return (Just v')+        in return (Array $ vInsert i v' v)+    go (AKey i : path) v' (Array v) =+        let fn :: Maybe Value -> Result (Maybe Value)+            fn Nothing = cannot "insert" "array" i from+            fn (Just d) = Just <$> go path v' d+        in Array <$> vModify i fn v+    go [OKey n] v' (Object m) =+        return . Object $ HM.insert n v' m+    go (OKey n : path) v' (Object o) =+        let fn :: Maybe Value -> Result (Maybe Value)+            fn Nothing = cannot "insert" "object" n from+            fn (Just d) = Just <$> go path v' d+        in Object <$> hmModify n fn o+    go (OKey n : path) v' array@(Array v)+        | n == "-" = go (AKey (V.length v) : path) v' array+    go path _ v = pointerFailure path v  -- | Apply a 'Rem' operation to a document. -- -- http://tools.ietf.org/html/rfc6902#section-4.2 -- -- - The target location MUST exist.-applyRem :: Path -> Value -> Result Value-applyRem [] _ = return Null-applyRem [AKey i] d@(Array v) =-    let fn :: Maybe Value -> Result (Maybe Value)-        fn Nothing = fail $ "Cannot delete missing array member at " <> show i <> " " <> BS.unpack (encode d)-        fn (Just v) = return Nothing-    in Array <$> vModify i fn v-applyRem (AKey i : path) (Array v) =-    let fn :: Maybe Value -> Result (Maybe Value)-        fn Nothing = fail "Cannot traverse under missing array index."-        fn (Just o) = Just <$> applyRem path o-    in Array <$> vModify i fn v-applyRem [OKey n] (Object m) =-    let fn :: Maybe Value -> Result (Maybe Value)-        fn Nothing = fail "Cannot delete missing object member."-        fn (Just _) = return Nothing-    in Object <$> hmModify n fn m-applyRem (OKey n : path) (Object m) =-    let fn :: Maybe Value -> Result (Maybe Value)-        fn Nothing = fail "Cannot traverse under missing object index."-        fn (Just o) = Just <$> applyRem path o-    in Object <$> hmModify n fn m--- Dodgy hack for "-" key which means "the end of the array".-applyRem (OKey n : path) array@(Array v)-    | n == "-" = applyRem (AKey (V.length v) : path) array--- Type mismatch: clearly the thing we're deleting isn't here.-applyRem path value = pointerFailure path value+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+            fn (Just _) = return Nothing+        in Object <$> hmModify n fn m+    go (OKey n : path) (Object m) =+        let fn :: Maybe Value -> Result (Maybe Value)+            fn Nothing = cannot "traverse" "object" n from+            fn (Just o) = Just <$> go path o+        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+    -- Type mismatch: clearly the thing we're deleting isn't here.+    go path value = pointerFailure path value  -- | Apply a 'Rep' operation to a document. -- -- http://tools.ietf.org/html/rfc6902#section-4.3 -- -- - Functionally identical to a 'Rem' followed by an 'Add'.-applyRep :: Path -> Value -> Value -> Result Value-applyRep path v doc = applyRem path doc >>= applyAdd path v+applyRep :: Pointer -> Value -> Value -> Result Value+applyRep from v doc = applyRem from doc >>= applyAdd from v  -- | Apply a 'Mov' operation to a document. -- -- http://tools.ietf.org/html/rfc6902#section-4.4-applyMov :: Path -> Path -> Value -> Result Value+applyMov :: Pointer -> Pointer -> Value -> Result Value applyMov path from doc = do   v <- get from doc   applyRem from doc >>= applyAdd path v@@ -458,7 +302,7 @@ -- -- - The location must exist. -- - Identical to an add with the appropriate value.-applyCpy :: Path -> Path -> Value -> Result Value+applyCpy :: Pointer -> Pointer -> Value -> Result Value applyCpy path from doc = do   v <- get from doc   applyAdd path v doc@@ -469,63 +313,18 @@ -- -- - The location must exist. -- - The value must be equal to the supplied value.-applyTst :: Path -> Value -> Value -> Result Value+applyTst :: Pointer -> Value -> Value -> Result Value applyTst path v doc = do     v' <- get path doc-    unless (v == v') (Error "Tested elements do not match.")+    unless (v == v') (Error . T.unpack $ "Element at \"" <> formatPointer path <> "\" fails test.")     return doc --- | Get the value at a 'Path'.------ - The path must exist.-get :: Path -> Value -> Result Value-get [] v = return v-get (AKey i : path) (Array v) =-    maybe (fail "") return (v V.!? i) >>= get path-get (OKey n : path) (Object v) =-    maybe (fail "") return (HM.lookup n v) >>= get path-get path value = pointerFailure path value---- * Formatting patches---- | Format a 'Patch' for reading by humans.------ For storing or exchanging 'Patch'es between systems using the JSON encoding--- implemented by the 'FromJSON' and 'ToJSON' instances.-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 (Add (Pointer k) v) = formatPath k <> "\n" <> "+" <> formatValue v-    formatOp (Rem (Pointer k) _) = formatPath k <> "\n" <> "-"-    formatOp (Rep (Pointer k) v) = formatPath k <> "\n" <> "=" <> formatValue v-    formatOp (Mov (Pointer k) (Pointer f)) = formatPath k <> "\n" <> "<" <> formatPath f-    formatOp (Cpy (Pointer k) (Pointer f)) = formatPath k <> "\n" <> "~" <> formatPath f-    formatOp (Tst (Pointer 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. +-- $ 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.@@ -562,7 +361,11 @@ -- - delete an existing element; -- - insert a new element; or -- - replace an existing element.-vModify :: Int -> (Maybe a -> Result (Maybe a)) -> Vector a -> Result (Vector a)+vModify+    :: Int+    -> (Maybe a -> Result (Maybe a))+    -> Vector a+    -> Result (Vector a) vModify i f v =     let a = v V.!? i         a' = f a@@ -571,7 +374,7 @@         (Just _ , Success Nothing ) -> return (vDelete i v)         (Nothing, Success (Just n)) -> return (vInsert i n v)         (Just _ , Success (Just n)) -> return (V.update v (V.singleton (i, n)))-        (_      , Error   e       ) -> fail e+        (_      , Error   e       ) -> Error e  -- | Modify the value associated with a key in a 'HashMap'. --@@ -588,3 +391,15 @@     Error e -> Error e     Success Nothing  -> return $ HM.delete k m     Success (Just v) -> return $ HM.insert k v m++-- | Report an error about being able to use a pointer key.+cannot+    :: (Show ix)+    => String -- ^ Use to be made "delete", "traverse", etc.+    -> String -- ^ Type "array" "object"+    -> ix+    -> Pointer+    -> Result a+cannot op ty ix p =+    Error ("Cannot " <> op <> " missing " <> ty <> " member at index "+          <> show ix <> " in pointer \"" <> T.unpack (formatPointer p) <> "\".")

@@ -0,0 +1,107 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}++-- | Description: Represent RFC 6902 patches.+module Data.Aeson.Patch (+  Patch(..),+  Operation(..),+) where++import           Control.Applicative+import           Control.Monad+import           Data.Aeson+import           Data.Aeson.Types+import qualified Data.ByteString.Lazy.Char8 as BS+import           Data.Monoid+import           Data.Vector                (Vector)+import qualified Data.Vector                as V++import Data.Aeson.Pointer++-- * Patches++-- | Describes the changes between two JSON documents.+newtype Patch = Patch+    { patchOperations :: [Operation] }+  deriving (Eq, Show, Monoid)++instance ToJSON Patch where+    toJSON (Patch ops) = toJSON ops++instance FromJSON Patch where+    parseJSON = modifyFailure ("Could not parse patch: " <> ) . parsePatch+      where+        parsePatch (Array v) = Patch <$> mapM parseJSON (V.toList v)+        parsePatch v = typeMismatch "Array" v++-- * Operations++-- | An 'Operation' describes the operations which can appear as part of a JSON+-- Patch.+--+-- See RFC 6902 Section 4 <http://tools.ietf.org/html/rfc6902#section-4>.+data Operation+    = Add { changePointer :: Pointer, changeValue :: Value }+    -- ^ http://tools.ietf.org/html/rfc6902#section-4.1+    | Rem { changePointer :: Pointer }+    -- ^ http://tools.ietf.org/html/rfc6902#section-4.2+    | Rep { changePointer :: Pointer, changeValue :: Value }+    -- ^ http://tools.ietf.org/html/rfc6902#section-4.3+    | Mov { changePointer :: Pointer, fromPointer :: Pointer }+    -- ^ http://tools.ietf.org/html/rfc6902#section-4.4+    | Cpy { changePointer :: Pointer, fromPointer :: Pointer }+    -- ^ http://tools.ietf.org/html/rfc6902#section-4.5+    | Tst { changePointer :: Pointer, changeValue :: Value }+    -- ^ http://tools.ietf.org/html/rfc6902#section-4.6+  deriving (Eq, Show)++instance ToJSON Operation where+    toJSON (Add p v) = object+        [ ("op", "add")+        , "path"  .= p+        , "value" .= v+        ]+    toJSON (Rem p) = object+        [ ("op", "remove")+        , "path" .= p+        ]+    toJSON (Rep p v) = object+        [ ("op", "replace")+        , "path"  .= p+        , "value" .= v+        ]+    toJSON (Mov p f) = object+        [ ("op", "move")+        , "path" .= p+        , "from" .= f+        ]+    toJSON (Cpy p f) = object+        [ ("op", "copy")+        , "path" .= p+        , "from" .= f+        ]+    toJSON (Tst p v) = object+        [ ("op", "test")+        , "path" .= p+        , "value" .= v+        ]++instance FromJSON Operation where+    parseJSON = parse+      where+        parse o@(Object v)+            =   (op v "add"     *> (Add <$> v .: "path" <*> v .: "value"))+            <|> (op v "replace" *> (Rep <$> v .: "path" <*> v .: "value"))+            <|> (op v "move"    *> (Mov <$> v .: "path" <*> v .: "from"))+            <|> (op v "copy"    *> (Cpy <$> v .: "path" <*> v .: "from"))+            <|> (op v "test"    *> (Tst <$> v .: "path" <*> v .: "value"))+            <|> (op v "remove"  *> (Rem <$> v .: "path"))+            <|> fail ("Expected a JSON patch operation, encountered: " <> BS.unpack (encode o))+        parse v = typeMismatch "Operation" v+        op v n = fixed v "op" (String n)+        fixed o n val = do+            v' <- o .: n+            if v' == val+              then return v'+              else mzero+        fixed' o n val = (o .: n) >>= \v -> guard (v == n)

@@ -0,0 +1,113 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+-- | Description: JSON Pointers as described in RFC 6901.++module Data.Aeson.Pointer (+  Pointer(..),+  Key(..),+  pointerFailure,+  Path,+  formatPointer,+  get,+) where++import           Control.Applicative+import           Data.Aeson+import           Data.Aeson.Types+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.Text                  (Text)+import qualified Data.Text                  as T+import qualified Data.Vector                as V++-- * Patch components++-- | 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.+  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."++formatKey :: Key -> Text+formatKey (AKey i) = T.pack (show i)+formatKey (OKey t) = T.concatMap esc t+  where+    esc :: Char -> Text+    esc '~' = "~0"+    esc '/' = "~1"+    esc c = T.singleton c++-- * Pointers++-- | A sequence of 'Key's forms a path through a JSON document.+type Path = [Key]++-- | Pointer to a location in a JSON document.+--+-- Defined in RFC 6901 <http://tools.ietf.org/html/rfc6901>+newtype Pointer = Pointer { pointerPath :: Path }+  deriving (Eq, Show, Monoid)++-- | Format a 'Pointer' as described in RFC 6901.+formatPointer :: Pointer -> Text+formatPointer (Pointer path) = "/" <> T.intercalate "/" (formatKey <$> path)++-- | Report an error following a pointer.+pointerFailure :: Path -> Value -> Result a+pointerFailure [] value = Error ("UNPOSSIBLE!" <> show value)+pointerFailure path@(key:rest) value =+    fail . BS.unpack $ "Cannot follow pointer " <> pt <> ". Expected " <> ty <> " but got " <> doc+  where+    doc = encode value+    pt = encode (Pointer path)+    ty = case key of+           (AKey _) -> "array"+           (OKey _) -> "object"++instance ToJSON Pointer where+    toJSON pointer =+        String (formatPointer pointer)++instance FromJSON Pointer where+    parseJSON = modifyFailure ("Could not parse JSON pointer: " <>) . parse+      where+        parse (String t) = Pointer <$> mapM key (drop 1 $ T.splitOn "/" t)+        parse _ = fail "A JSON pointer must be a string."+        step t+              | "0" `T.isPrefixOf` t = T.cons '~' (T.tail t)+              | "1" `T.isPrefixOf` t = T.cons '/' (T.tail t)+              | otherwise = T.cons '~' t+        unesc :: Text -> Text+        unesc 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))+            | otherwise        = return $ OKey (unesc t)++-- | Get the value at a 'Path'.+get :: Pointer -> Value -> Result Value+get (Pointer p) = get' p+  where+    get' [] v = return v+    get' (AKey i : path) (Array v) =+        maybe (fail "") return (v V.!? i) >>= get' path+    get' (OKey n : path) (Object v) =+        maybe (fail "") return (HM.lookup n v) >>= get' path+    get' path value = pointerFailure path value

@@ -19,20 +19,27 @@  -- | Command-line options. data Options = Options-    { optionOut  :: File+    { optionTst  :: Bool+    , optionOut  :: File     , optionFrom :: File     , optionTo   :: File     }  data Configuration = Configuration-    { cfgOut  :: Handle+    { cfgTst  :: Bool+    , cfgOut  :: Handle     , cfgFrom :: Handle     , cfgTo   :: Handle     }  optionParser :: Parser Options optionParser = Options-    <$> option fileP+    <$> switch+        (  long "test-before-remove"+        <> short 'T'+        <> help "Include a test before each remove."+        )+    <*> option fileP         (  long "output"         <> short 'o'         <> metavar "OUTPUT"@@ -72,7 +79,8 @@     load :: Options -> IO Configuration     load Options{..} =         Configuration-            <$> openw optionOut+            <$> pure  optionTst+            <*> openw optionOut             <*> openr optionFrom             <*> openr optionTo 

@@ -0,0 +1,1 @@+Cannot delete missing object member at index "missing" in pointer "/missing".

@@ -0,0 +1,3 @@+{+    "a": 1+}

@@ -0,0 +1,2 @@+[ {"op": "remove", "path": "/missing"}+]

@@ -0,0 +1,1 @@+Cannot delete missing array member at index 1 in pointer "/1".

@@ -0,0 +1,2 @@+[ "hello"+]

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

@@ -1,1 +1,1 @@-Cannot insert beneath missing object index: "baz"+Cannot insert missing object member at index "baz" in pointer "/baz/bat".

@@ -1,1 +1,1 @@-Tested elements do not match.+Element at "/~01" fails test.

@@ -1,1 +1,1 @@-Tested elements do not match.+Element at "/baz" fails test.

@@ -8,7 +8,7 @@  import           Control.Applicative import           Control.Monad-import           Data.Aeson+import           Data.Aeson                 as A import qualified Data.ByteString.Lazy.Char8 as BL import           Data.Functor import           Data.HashMap.Strict        (HashMap)@@ -76,9 +76,13 @@     -> Bool diffApply f t =     let p = diff f t-    in (t == patch' p f) ||+    in (A.Success t == patch p f) ||        error ("BAD PATCH\n" <> BL.unpack (encode p) <> "\n"-                            <> BL.unpack (encode (patch' p f)))+                            <> result "<failure>" (BL.unpack . encode <$> patch p f))++result :: a -> A.Result a -> a+result _ (A.Success a) = a+result a _ = a  -- | Patch extracted from identical documents should be mempty. prop_diff_id