packages feed

aeson-diff 0.1.1.3 → 1.0.0.0

raw patch · 64 files changed

+1042/−232 lines, 64 filesdep +Globdep +directorydep +filepathdep ~aesondep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: Glob, directory, filepath, hlint

Dependency ranges changed: aeson, base, bytestring

API changes (from Hackage documentation)

- Data.Aeson.Diff: Del :: Path -> Value -> Operation
- Data.Aeson.Diff: Ins :: Path -> Value -> Operation
- Data.Aeson.Diff: [changePath] :: Operation -> Path
- Data.Aeson.Diff: type Path = [Key]
+ Data.Aeson.Diff: Add :: Pointer -> Value -> Operation
+ Data.Aeson.Diff: Cpy :: Pointer -> Pointer -> Operation
+ Data.Aeson.Diff: Mov :: Pointer -> Pointer -> Operation
+ Data.Aeson.Diff: Rem :: Pointer -> Value -> Operation
+ Data.Aeson.Diff: Rep :: Pointer -> Value -> Operation
+ Data.Aeson.Diff: Tst :: Pointer -> Value -> Operation
+ Data.Aeson.Diff: [changePointer] :: Operation -> Pointer
+ Data.Aeson.Diff: [fromPointer] :: Operation -> Pointer
+ Data.Aeson.Diff: data Pointer
+ Data.Aeson.Diff: instance Data.Aeson.Types.Class.FromJSON Data.Aeson.Diff.Pointer
+ Data.Aeson.Diff: instance Data.Aeson.Types.Class.ToJSON Data.Aeson.Diff.Pointer
+ Data.Aeson.Diff: instance GHC.Base.Monoid Data.Aeson.Diff.Pointer
+ Data.Aeson.Diff: instance GHC.Classes.Eq Data.Aeson.Diff.Pointer
+ Data.Aeson.Diff: instance GHC.Show.Show Data.Aeson.Diff.Pointer
+ Data.Aeson.Diff: patch' :: Patch -> Value -> Value
- Data.Aeson.Diff: applyOperation :: Operation -> Value -> Value
+ Data.Aeson.Diff: applyOperation :: Operation -> Value -> Result Value
- Data.Aeson.Diff: patch :: Patch -> Value -> Value
+ Data.Aeson.Diff: patch :: Patch -> Value -> Result Value

Files

CHANGELOG.md view
@@ -1,3 +1,15 @@ aeson-diff 1.0 +    * aeson-diff now supports the operations and patch format described in+      RFC6902.++    * 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 command line applications no longer pretend to support a non-JSON+      patch format.++aeson-diff 0.1+     * Initial release.
README.md view
@@ -3,19 +3,30 @@  [![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).+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). Patches are themselves JSON Patch documents as specified in+[RFC 6902][3].  Installing ----------  The `aeson-diff` package is written in Haskell and can be installed using the-Cabal package management tool.+[Cabal][1] package management tool, [stack][2], or something similar. -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+stack install aeson-diff+```` +The command-line tools can then be executed using stack:++````+stack exec json-diff -- ....+stack exec json-patch -- ....+````++If you prefer to use Cabal, something like this might do the trick:+ ````bash cd aeson-diff/ cabal sandbox init@@ -25,29 +36,25 @@ 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 ----- +### Patch format++`aeson-diff` supports the JSON Patch format described in+[RFC 6902][3].+ ### 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+Usage: json-diff [-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@@ -56,12 +63,11 @@ a JSON document.  ````-Usage: json-patch [-j|--json] [-o|--output OUTPUT] PATCH FROM+Usage: json-patch [-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.@@ -75,11 +81,17 @@ - `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`.+`Value`. If an error results then an exception is thrown.  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+[1]: https://wiki.haskell.org/Cabal-Install+[2]: http://haskellstack.org/+[3]: http://tools.ietf.org/html/rfc6902
aeson-diff.cabal view
@@ -1,5 +1,5 @@ name:                aeson-diff-version:             0.1.1.3+version:             1.0.0.0 synopsis:            Extract and apply patches to JSON documents. description:   .@@ -15,8 +15,14 @@ copyright:           (c) 2015 Thomas Sutton and others. category:            JSON, Web, Algorithms build-type:          Simple-extra-source-files:  README.md, CHANGELOG.md, stack.yaml cabal-version:       >=1.10+extra-source-files:  README.md+                   , CHANGELOG.md+                   , stack.yaml+                   , test/data/rfc6902/*.json+                   , test/data/rfc6902/*.txt+                   , test/data/cases/*.json+                   , test/data/cases/*.txt  source-repository     HEAD   type: git@@ -67,7 +73,34 @@                      , QuickCheck                      , aeson                      , aeson-diff+                     , bytestring                      , quickcheck-instances                      , text                      , unordered-containers                      , vector++test-suite             examples+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             examples.hs+  build-depends:       base+                     , Glob+                     , QuickCheck+                     , aeson+                     , aeson-diff+                     , bytestring+                     , directory+                     , filepath+                     , quickcheck-instances+                     , text+                     , unordered-containers+                     , vector++test-suite             hlint-check+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             hlint-check.hs+  build-depends:       base+                     , hlint
lib/Data/Aeson/Diff.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}  -- | Description: Extract and apply patches on JSON documents. --@@ -9,32 +11,38 @@ module Data.Aeson.Diff (     -- * Patches     Patch(..),-    Path,+    Pointer,     Key(..),     Operation(..),      -- * Functions     diff,     patch,+    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           Control.Applicative+import           Control.Monad+import           Control.Monad.Error.Class+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)+import qualified Data.HashMap.Strict        as HM+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           Data.Vector                (Vector)+import qualified Data.Vector                as V  import Data.Vector.Distance @@ -51,48 +59,122 @@     mappend (Patch p1) (Patch p2) = Patch $ p1 <> p2  instance ToJSON Patch where-    toJSON (Patch ops) = object [ "patch" .= ops ]+    toJSON (Patch ops) = toJSON ops  instance FromJSON Patch where-    parseJSON (Object v) = Patch <$> v .: "patch"-    parseJSON _ = fail "Patch must be a JSON object."+    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 (Ins p v) = object-        [ ("change", "insert")+    toJSON (Add p v) = object+        [ ("op", "add")         , "path"  .= p         , "value" .= v         ]-    toJSON (Del p v) = object-        [ ("change", "delete")+    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 (Object v)-        =  (fixed v "change" (String "insert") *>-            (Ins <$> v .: "path" <*> v .: "value"))-        <> (fixed v "change" (String "delete") *>-            (Del <$> v .: "path" <*> v .: "value"))+    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-            unless (v' == val) . fail . T.unpack $ "Cannot find " <> n <> "."-            return v'-    parseJSON _ = fail "Operation must be a JSON object."+            if v' == val+              then return v'+              else mzero+    parseJSON v = typeMismatch "Operation" v --- | An 'Operation' describes an atomic change to a JSON document: inserting or--- deleting a single 'Value' at a specific point.-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)+operationCost :: Operation -> Int+operationCost op =+    case op of+      Add{} -> valueSize (changeValue op)+      Rem{} -> valueSize (changeValue op)+      Rep{} -> valueSize (changeValue op)+      Mov{} -> 1+      Cpy{} -> 1+      Tst{} -> valueSize (changeValue op) --- | A path through a JSON document is a possibly empty sequence of 'Key's.-type Path = [Key]+-- | Modify the 'Pointer's of an 'Operation'.+--+-- This is typically used to add a prefix to the 'Pointer's in an+modifyPath :: ([Key] -> [Key]) -> Operation -> Operation+modifyPath f op = from (change op)+  where+    fn :: Pointer -> Pointer+    fn (Pointer p) = Pointer (f p)+    change op = op { changePointer = fn (changePointer op) }+    from op =+        case op of+          Mov{} -> op { fromPointer = fn (fromPointer op) }+          Cpy{} -> op { fromPointer = fn (fromPointer op) }+          _     -> op  -- | Traverse a single layer of a JSON document. data Key@@ -100,6 +182,34 @@     | 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@@ -112,25 +222,19 @@             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.+-- | Construct a patch with a single 'Add' operation. ins :: Path -> Value -> Patch-ins p v = Patch [Ins p v]+ins p v = Patch [Add (Pointer p) v] --- | Construct a patch with a single 'Del' operation.+-- | Construct a patch with a single 'Rem' operation. del :: Path -> Value -> Patch-del p v = Patch [Del p v]+del p v = Patch [Rem (Pointer p) v] --- | Construct a patch which changes a single value.------ This just deletes the old value and inserts the new one.-ch :: Path -> Value -> Value -> Patch-ch p v1 v2 = del p v1 <> ins p v2+-- | Construct a patch which changes 'Rep' operation.+rep :: Path -> Value -> Patch+rep p v = Patch [Rep (Pointer p) v]  -- * Operations @@ -148,109 +252,240 @@     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+        (Bool b1,   Bool b2)   -> check (b1 == b2) $ rep p v2+        (Number n1, Number n2) -> check (n1 == n2) $ rep p v2+        (String s1, String s2) -> check (s1 == s2) $ rep p v2          -- For structured values of the same type, walk them.-        (Array a1,  Array a2)  -> check (a1 == a2) $ workArray p a1 a2+        (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+        -- For values of different types, replace v1 with v2.+        _                      -> rep p v2      -- Walk the keys in two objects, producing a 'Patch'.     workObject :: Path -> Object -> Object -> Patch-    workObject p o1 o2 =+    workObject path 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)+                (\k -> Rem (Pointer [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)+                (\k -> Add (Pointer [OKey k]) . fromJust $ HM.lookup k o2)                 ins_keys             -- Changes             chg_keys = filter (`elem` k2) k1             changes = fmap-                (\k -> worker (p <> [OKey k])+                (\k -> worker [OKey k]                     (fromJust $ HM.lookup k o1)                     (fromJust $ HM.lookup k o2))                 chg_keys-        in deletions <> insertions <> mconcat changes+        in Patch . fmap (modifyPath (path <>)) . patchOperations $ (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+    workArray path ss tt = Patch . fmap (modifyPath (path <>)) . 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]+        delete i v = [Rem (Pointer [AKey i]) v]+        insert i v = [Add (Pointer [AKey i]) v]         substitute i v v' =-            let p = path <> [AKey i]+            let p = [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+        cost = Sum . sum . fmap operationCost+        -- Position is advanced by grouping operations with same "head" index:+        -- + groups of many operations advance one+        -- + singletons with |pointer|>1 advance one+        -- + other singletons advance according to 'pos'+        positionOffset = sum . fmap adv . groupBy related+        related :: Operation -> Operation -> Bool+        related o1 o2 =+            let p1 = pointerPath (changePointer o1)+                p2 = pointerPath (changePointer o2)+            in case (p1, p2) of+                 ([i1], [i2]) -> False+                 (i1:_, i2:_) | i1 == i2  -> True+                              | otherwise -> False+        -- A group of operations has a peculiar (i.e. given by 'pos') advance+        -- when it's a single op and |changePointer| = 1; otherwise it's a+        -- bunch of changes inside the head key.+        adv :: [Operation] -> Int+        adv [op]+            | (length . pointerPath . changePointer $ op) == 1 = pos op+        adv _    = 1+        pos :: Operation -> Int+        pos Rem{changePointer=Pointer path}+            | length path == 1 = 0+            | otherwise        = 0+        pos Add{changePointer=Pointer path}+            | length path == 1 = 1+            | otherwise        = 0+        pos Rep{changePointer=Pointer path}+            | length path == 1 = 1+            | otherwise        = 0+        pos Cpy{changePointer=Pointer path}+            | length path == 1 = 1+            | otherwise        = 0+        pos Mov{changePointer=Pointer path}+            | length path == 1 = 1+            | otherwise        = 0+        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-    -> Value-patch (Patch []) val = val-patch (Patch ops) val = foldl (flip applyOperation) val ops+    -> Result Value+patch (Patch []) val = return val+patch (Patch ops) val = foldlM (flip applyOperation) val ops  -- | Apply an 'Operation' to a 'Value'. applyOperation     :: Operation     -> Value-    -> Value+    -> Result 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)+    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 -    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+-- | Apply an 'Add' operation to a document.+--+-- http://tools.ietf.org/html/rfc6902#section-4.1+--+-- - An empty 'Path' replaces the document.+-- - 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 +-- | 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++-- | 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++-- | Apply a 'Mov' operation to a document.+--+-- http://tools.ietf.org/html/rfc6902#section-4.4+applyMov :: Path -> Path -> Value -> Result Value+applyMov path from doc = do+  v <- get from doc+  applyRem from doc >>= applyAdd path v++-- | Apply a 'Cpy' operation to a document.+--+-- http://tools.ietf.org/html/rfc6902#section-4.5+--+-- - The location must exist.+-- - Identical to an add with the appropriate value.+applyCpy :: Path -> Path -> Value -> Result Value+applyCpy path from doc = do+  v <- get from doc+  applyAdd path v doc++-- | Apply a 'Tst' operation to a document.+--+-- http://tools.ietf.org/html/rfc6902#section-4.6+--+-- - The location must exist.+-- - The value must be equal to the supplied value.+applyTst :: Path -> Value -> Value -> Result Value+applyTst path v doc = do+    v' <- get path doc+    unless (v == v') (Error "Tested elements do not match.")+    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.@@ -274,8 +509,12 @@         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+    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@@ -323,15 +562,16 @@ -- - delete an existing element; -- - insert a new element; or -- - replace an existing element.-vModify :: Int -> (Maybe a -> Maybe a) -> Vector a -> 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     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))+        (Nothing, Success Nothing ) -> return v+        (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  -- | Modify the value associated with a key in a 'HashMap'. --@@ -341,9 +581,10 @@ hmModify     :: (Eq k, Hashable k)     => k-    -> (Maybe v -> Maybe v)-    -> HashMap k v+    -> (Maybe v -> Result (Maybe v))     -> HashMap k v+    -> Result (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+    Error e -> Error e+    Success Nothing  -> return $ HM.delete k m+    Success (Just v) -> return $ HM.insert k v m
src/diff.hs view
@@ -3,43 +3,36 @@  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+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+    { optionOut  :: File     , optionFrom :: File     , optionTo   :: File     }  data Configuration = Configuration-    { cfgJSON :: Bool-    , cfgOut  :: Handle+    { cfgOut  :: Handle     , cfgFrom :: Handle     , cfgTo   :: Handle     }  optionParser :: Parser Options optionParser = Options-    <$> switch-        (  long "json"-        <> short 'j'-        <> help "Output patch in JSON."-        )-    <*> option fileP+    <$> option fileP         (  long "output"         <> short 'o'         <> metavar "OUTPUT"@@ -61,7 +54,7 @@ jsonFile :: Handle -> IO Value jsonFile fp = do     s <- BS.hGetContents fp-    case decode (BSL.fromStrict s)of+    case decode (BSL.fromStrict s) of         Nothing -> error "Could not parse as JSON"         Just v -> return v @@ -79,8 +72,7 @@     load :: Options -> IO Configuration     load Options{..} =         Configuration-            <$> pure  optionJSON-            <*> openw optionOut+            <$> openw optionOut             <*> openr optionFrom             <*> openr optionTo @@ -95,9 +87,7 @@     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+    BS.hPutStrLn cfgOut $ BSL.toStrict (encode p)  main :: IO () main = execParser opts >>= run
src/patch.hs view
@@ -2,42 +2,35 @@  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+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+    { optionOut   :: File -- ^ JSON destination     , optionPatch :: File -- ^ Patch input     , optionFrom  :: File -- ^ JSON source     }  data Configuration = Configuration-    { cfgJSON  :: Bool-    , cfgOut   :: Handle+    { cfgOut   :: Handle     , cfgPatch :: Handle     , cfgFrom  :: Handle     }  optionParser :: Parser Options optionParser = Options-    <$> switch-        (  long "json"-        <> short 'j'-        <> help "Patch is in JSON format."-        )-    <*> option fileP+    <$> option fileP         (  long "output"         <> short 'o'         <> metavar "OUTPUT"@@ -62,7 +55,7 @@ jsonRead :: Handle -> IO Value jsonRead fp = do     s <- BS.hGetContents fp-    case decode (BSL.fromStrict s)of+    case decode (BSL.fromStrict s) of         Nothing -> error "Could not parse as JSON"         Just v -> return v @@ -80,8 +73,7 @@     load :: Options -> IO Configuration     load Options{..} =         Configuration-            <$> pure  optionJSON-            <*> openw optionOut+            <$> openw optionOut             <*> openr optionPatch             <*> openr optionFrom @@ -93,14 +85,11 @@  process :: Configuration -> IO () process Configuration{..} = do-    json_patch <- if cfgJSON-        then jsonRead cfgPatch-        else error "Patch must be in JSON format. Sorry :-("+    json_patch <- jsonRead cfgPatch     json_from <- jsonRead cfgFrom-    case fromJSON json_patch of+    case fromJSON json_patch >>= flip patch json_from of         Error e -> error e-        Success p -> BS.hPutStrLn cfgOut . BSL.toStrict . encode-                $ patch p json_from+        Success d -> BS.hPutStrLn cfgOut $ BSL.toStrict (encode d)  main :: IO () main = execParser opts >>= run
stack.yaml view
@@ -1,6 +1,5 @@-resolver: lts-4.1-packages:-- .-extra-deps: []+resolver: lts-5.11+extra-deps:+- edit-distance-vector-1.0.0.3 flags: {} extra-package-dbs: []
+ test/data/cases/case1-original.json view
@@ -0,0 +1,13 @@+[+   [+      0,+      1,+      2,+      3+   ],+   [+      "a",+      "b",+      "c"+   ]+]
+ test/data/cases/case1-patch.json view
@@ -0,0 +1,20 @@+[+   {+      "path" : "/0/0",+      "op" : "remove"+   },+   {+      "path" : "/0/0",+      "op" : "remove"+   },+   {+      "value" : null,+      "path" : "/0/0",+      "op" : "add"+   },+   {+      "path" : "/1",+      "value" : true,+      "op" : "add"+   }+]
+ test/data/cases/case1-result.json view
@@ -0,0 +1,13 @@+[+   [+      null,+      2,+      3+   ],+   true,+   [+      "a",+      "b",+      "c"+   ]+]
+ test/data/cases/case2-original.json view
@@ -0,0 +1,6 @@+[+    [[null],+     []],+    {"":[-1]},+    {"wut":{"":-1}}+]
+ test/data/cases/case2-patch.json view
@@ -0,0 +1,7 @@+[+    {"op":"replace","path":"/0/0","value":{}},+    {"op":"remove","path":"/0/1"},+    {"op":"replace","path":"/1","value":[]},+    {"op":"add","path":"/2/hello","value":[0]},+    {"op":"replace","path":"/2/wut","value":[false]}+]
+ test/data/cases/case2-result.json view
@@ -0,0 +1,1 @@+[[{}],[],{"wut":[false],"hello":[0]}]
+ test/data/cases/case3-error.txt view
@@ -0,0 +1,1 @@+Could not parse patch: when expecting a Array, encountered Object instead
+ test/data/cases/case3-original.json view
@@ -0,0 +1,1 @@+{}
+ test/data/cases/case3-patch.json view
@@ -0,0 +1,4 @@+{+    "name" : "Hello"+}+
+ test/data/rfc6902/a1-original.json view
@@ -0,0 +1,3 @@+{+    "foo": "bar"+}
+ test/data/rfc6902/a1-patch.json view
@@ -0,0 +1,7 @@+[+    {+        "op": "add",+        "path": "/baz",+        "value": "qux"+    }+]
+ test/data/rfc6902/a1-result.json view
@@ -0,0 +1,4 @@+{+    "baz": "qux",+    "foo": "bar"+}
+ test/data/rfc6902/a10-original.json view
@@ -0,0 +1,3 @@+{+    "foo": "bar"+}
+ test/data/rfc6902/a10-patch.json view
@@ -0,0 +1,9 @@+[+    {+        "op": "add",+        "path": "/child",+        "value": {+            "grandchild": {}+        }+    }+]
+ test/data/rfc6902/a10-result.json view
@@ -0,0 +1,6 @@+{+    "child": {+        "grandchild": {}+    },+    "foo": "bar"+}
+ test/data/rfc6902/a11-original.json view
@@ -0,0 +1,3 @@+{+    "foo": "bar"+}
+ test/data/rfc6902/a11-patch.json view
@@ -0,0 +1,8 @@+[+    {+        "op": "add",+        "path": "/baz",+        "value": "qux",+        "xyz": 123+    }+]
+ test/data/rfc6902/a11-result.json view
@@ -0,0 +1,4 @@+{+    "baz": "qux",+    "foo": "bar"+}
+ test/data/rfc6902/a12-error.txt view
@@ -0,0 +1,1 @@+Cannot insert beneath missing object index: "baz"
+ test/data/rfc6902/a12-original.json view
@@ -0,0 +1,3 @@+{+    "foo": "bar"+}
+ test/data/rfc6902/a12-patch.json view
@@ -0,0 +1,7 @@+[+    {+        "op": "add",+        "path": "/baz/bat",+        "value": "qux"+    }+]
+ test/data/rfc6902/a14-original.json view
@@ -0,0 +1,4 @@+{+    "/": 9,+    "~1": 10+}
+ test/data/rfc6902/a14-patch.json view
@@ -0,0 +1,7 @@+[+    {+        "op": "test",+        "path": "/~01",+        "value": 10+    }+]
+ test/data/rfc6902/a14-result.json view
@@ -0,0 +1,4 @@+{+    "/": 9,+    "~1": 10+}
+ test/data/rfc6902/a15-error.txt view
@@ -0,0 +1,1 @@+Tested elements do not match.
+ test/data/rfc6902/a15-original.json view
@@ -0,0 +1,4 @@+{+    "/": 9,+    "~1": 10+}
+ test/data/rfc6902/a15-patch.json view
@@ -0,0 +1,7 @@+[+    {+        "op": "test",+        "path": "/~01",+        "value": "10"+    }+]
+ test/data/rfc6902/a16-original.json view
@@ -0,0 +1,5 @@+{+    "foo": [+        "bar"+    ]+}
+ test/data/rfc6902/a16-patch.json view
@@ -0,0 +1,10 @@+[+    {+        "op": "add",+        "path": "/foo/-",+        "value": [+            "abc",+            "def"+        ]+    }+]
+ test/data/rfc6902/a16-result.json view
@@ -0,0 +1,9 @@+{+    "foo": [+        "bar",+        [+            "abc",+            "def"+        ]+    ]+}
+ test/data/rfc6902/a2-original.json view
@@ -0,0 +1,6 @@+{+    "foo": [+        "bar",+        "baz"+    ]+}
+ test/data/rfc6902/a2-patch.json view
@@ -0,0 +1,7 @@+[+    {+        "op": "add",+        "path": "/foo/1",+        "value": "qux"+    }+]
+ test/data/rfc6902/a2-result.json view
@@ -0,0 +1,7 @@+{+    "foo": [+        "bar",+        "qux",+        "baz"+    ]+}
+ test/data/rfc6902/a3-original.json view
@@ -0,0 +1,4 @@+{+    "baz": "qux",+    "foo": "bar"+}
+ test/data/rfc6902/a3-patch.json view
@@ -0,0 +1,6 @@+[+    {+        "op": "remove",+        "path": "/baz"+    }+]
+ test/data/rfc6902/a3-result.json view
@@ -0,0 +1,3 @@+{+    "foo": "bar"+}
+ test/data/rfc6902/a4-original.json view
@@ -0,0 +1,7 @@+{+    "foo": [+        "bar",+        "qux",+        "baz"+    ]+}
+ test/data/rfc6902/a4-patch.json view
@@ -0,0 +1,6 @@+[+    {+        "op": "remove",+        "path": "/foo/1"+    }+]
+ test/data/rfc6902/a4-result.json view
@@ -0,0 +1,6 @@+{+    "foo": [+        "bar",+        "baz"+    ]+}
+ test/data/rfc6902/a5-original.json view
@@ -0,0 +1,4 @@+{+    "baz": "qux",+    "foo": "bar"+}
+ test/data/rfc6902/a5-patch.json view
@@ -0,0 +1,7 @@+[+    {+        "op": "replace",+        "path": "/baz",+        "value": "boo"+    }+]
+ test/data/rfc6902/a5-result.json view
@@ -0,0 +1,4 @@+{+    "baz": "boo",+    "foo": "bar"+}
+ test/data/rfc6902/a6-original.json view
@@ -0,0 +1,9 @@+{+    "foo": {+        "bar": "baz",+        "waldo": "fred"+    },+    "qux": {+        "corge": "grault"+    }+}
+ test/data/rfc6902/a6-patch.json view
@@ -0,0 +1,7 @@+[+    {+        "from": "/foo/waldo",+        "op": "move",+        "path": "/qux/thud"+    }+]
+ test/data/rfc6902/a6-result.json view
@@ -0,0 +1,9 @@+{+    "foo": {+        "bar": "baz"+    },+    "qux": {+        "corge": "grault",+        "thud": "fred"+    }+}
+ test/data/rfc6902/a7-original.json view
@@ -0,0 +1,8 @@+{+    "foo": [+        "all",+        "grass",+        "cows",+        "eat"+    ]+}
+ test/data/rfc6902/a7-patch.json view
@@ -0,0 +1,7 @@+[+    {+        "from": "/foo/1",+        "op": "move",+        "path": "/foo/3"+    }+]
+ test/data/rfc6902/a7-result.json view
@@ -0,0 +1,8 @@+{+    "foo": [+        "all",+        "cows",+        "eat",+        "grass"+    ]+}
+ test/data/rfc6902/a8-original.json view
@@ -0,0 +1,8 @@+{+    "baz": "qux",+    "foo": [+        "a",+        2,+        "c"+    ]+}
+ test/data/rfc6902/a8-patch.json view
@@ -0,0 +1,12 @@+[+    {+        "op": "test",+        "path": "/baz",+        "value": "qux"+    },+    {+        "op": "test",+        "path": "/foo/1",+        "value": 2+    }+]
+ test/data/rfc6902/a8-result.json view
@@ -0,0 +1,8 @@+{+    "baz": "qux",+    "foo": [+        "a",+        2,+        "c"+    ]+}
+ test/data/rfc6902/a9-error.txt view
@@ -0,0 +1,1 @@+Tested elements do not match.
+ test/data/rfc6902/a9-original.json view
@@ -0,0 +1,3 @@+{+    "baz": "qux"+}
+ test/data/rfc6902/a9-patch.json view
@@ -0,0 +1,7 @@+[+    {+        "op": "test",+        "path": "/baz",+        "value": "bar"+    }+]
+ test/examples.hs view
@@ -0,0 +1,129 @@+{-# 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                  (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/rfc6902", "test/data/cases"]++globPattern :: FilePath+globPattern = "*.*"++derp :: String -> a+derp msg = throw (AssertionFailed $ " " <> msg)++readDocument :: FilePath -> FilePath -> IO Value+readDocument root name = do+    let file = root </> name <> "-original.json"+    doc <- eitherDecodeStrict <$> BS.readFile file++    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"++    eitherDecodeStrict <$> BS.readFile file++readResult :: FilePath -> FilePath -> IO (Either String Value)+readResult root name = do+    let err_path = root </> name <> "-error.txt"+    let doc_path = root </> name <> "-result.json"++    err <- catch (Just . BC.unpack . BC.dropWhile isSpace . fst . BC.spanEnd isSpace+                 <$> BS.readFile err_path) handle++    doc <- catch (decodeStrict <$> BS.readFile doc_path) handle++    case (err, doc) of+      (Nothing, Just d)  -> return (Right d)+      (Just er, Nothing) -> return (Left er)+      (Just er, Just d)  -> derp "Expecting both error and success"+      (Nothing, Nothing) -> derp "No result defined; add `*-error.txt' or `*-result.json'"+  where+    handle :: IOException -> IO (Maybe a)+    handle e = return Nothing++readExample :: FilePath -> FilePath -> IO (Value, Either String Patch, Either String Value)+readExample root name =+    (,,) <$> readDocument root name+         <*> readPatch root name+         <*> readResult root name++-- | Check example and, if it fails, return an error message.+runExample :: (Value, Either String Patch, Either String Value) -> Maybe String+runExample (doc, diff, res) =+    case (diff, res) of+        (Left perr, Left err)+            | perr == err -> success "Patch has expected error."+            | otherwise   -> failure ("Unexpected error `" <> perr <> "'.")+        (Left err, Right _) ->+            failure ("Couldn't load patch: " <> err)+        (Right diff, Right res) ->+            case patch diff doc of+              Success dest+                  | dest == res -> success "Result matches target"+                  | otherwise -> failure ("Result document did not match: " <> BL.unpack (encode dest))+              Error dest -> failure ("Couldn't apply patch " <> dest)+        (Right diff, Left err) ->+            case patch diff doc of+              Success _ -> Just "Test Fails - Expected a failure but patch succeeded."+              Error msg+                  | msg /= err -> Just $ "Test Fails - Got: " <> msg <> "\nExpected: " <> err+                  | otherwise  -> Nothing+  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/hlint-check.hs view
@@ -0,0 +1,18 @@+module Main (main) where++import Language.Haskell.HLint (hlint)+import System.Exit            (exitFailure, exitSuccess)++arguments :: [String]+arguments =+    [ "lib"+    , "src"+    , "test"+    ]++main :: IO ()+main = do+    hints <- hlint arguments+    if null hints+    then exitSuccess+    else exitFailure
test/properties.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell   #-} @@ -5,53 +6,110 @@  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           Control.Applicative+import           Control.Monad+import           Data.Aeson+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+import           System.Exit+import           Test.QuickCheck+import           Test.QuickCheck.Instances  ()  import Data.Aeson.Diff +showIt :: Value -> String+showIt = BL.unpack . encode++data Wellformed a = Wellformed { wellformed :: a }++data AnObject a = AnObject { anObject :: a }++data AnArray a = AnArray { anArray :: a }++instance Show (Wellformed Value) where+    show = showIt . wellformed++instance Show (AnObject Value) where+    show = showIt . anObject++instance Show (AnArray Value) where+    show = showIt . anArray++-- | QuickCheck doesn't have scale in LTS-2 so copy it in.+scaleSize :: (Int -> Int) -> Gen a -> Gen a+scaleSize f g = sized (\s -> resize (f s) g)++instance Arbitrary (Wellformed Value) where+    arbitrary = Wellformed <$> oneof+                [ Array . V.fromList <$> scaleSize (`div` 2) arbitrary+                , Object . HM.fromList <$> scaleSize (`div` 2) arbitrary+                ]++instance Arbitrary (AnObject Value) where+    arbitrary = AnObject . Object . HM.fromList <$> scaleSize (`div` 2) arbitrary++instance Arbitrary (AnArray Value) where+    arbitrary = AnArray . Array . V.fromList <$> scaleSize (`div` 2) arbitrary+ instance Arbitrary Value where-    arbitrary = elements-        [ Null-        , Bool True-        , Number 123-        , String "boo"-        , Array . V.fromList $ [String "123", Number 123]-        ]+    arbitrary = sized vals+      where vals :: Int -> Gen Value+            vals n+              | n <= 1 = oneof+                         [ pure Null+                         , Bool <$> arbitrary+                         , Number . fromIntegral <$> (arbitrary :: Gen Int)+                         , String <$> arbitrary+                         ]+              | otherwise = wellformed <$> arbitrary --- | 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+diffApply     :: Value     -> Value     -> Bool-prop_diff_apply f t = t == patch (diff f t) f+diffApply f t =+    let p = diff f t+    in (t == patch' p f) ||+       error ("BAD PATCH\n" <> BL.unpack (encode p) <> "\n"+                            <> BL.unpack (encode (patch' p f))) +-- | Patch extracted from identical documents should be mempty.+prop_diff_id+    :: Wellformed Value+    -> Bool+prop_diff_id (Wellformed v) =+    diff v v == mempty++-- | Extract and apply a patch (between wellformed JSON documents).+prop_diff_documents+    :: Wellformed Value+    -> Wellformed Value+    -> Bool+prop_diff_documents (Wellformed f) (Wellformed t) =+    diffApply f t+ -- | Extract and apply a patch (specialised to JSON arrays). prop_diff_arrays-    :: [Value]-    -> [Value]+    :: AnArray Value+    -> AnArray Value     -> Bool-prop_diff_arrays v1 v2 = prop_diff_apply (Array . V.fromList $ v1) (Array . V.fromList $ v2)+prop_diff_arrays (AnArray v1) (AnArray v2) =+    diffApply v1 v2  -- | Extract and apply a patch (specialised to JSON objects). prop_diff_objects-    :: HashMap Text Value-    -> HashMap Text Value+    :: AnObject Value+    -> AnObject Value     -> Bool-prop_diff_objects m1 m2 = prop_diff_apply (Object m1) (Object m2)+prop_diff_objects (AnObject m1) (AnObject m2) =+    diffApply m1 m2  -- -- Use Template Haskell to automatically run all of the properties above.