summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorThomasSutton <>2017-03-20 22:44:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-03-20 22:44:00 (GMT)
commit9f47cda32e584afa006f39f7f3b6a1bc30d7a987 (patch)
tree5a8fae88896f00f6806038bc09d06cd7a2f73f01
parent079b390c369468a04b5938da5914d869f6177a78 (diff)
version 1.1.0.2HEAD1.1.0.2master
-rw-r--r--README.md2
-rw-r--r--aeson-diff.cabal16
-rw-r--r--lib/Data/Aeson/Diff.hs129
-rw-r--r--lib/Data/Aeson/Patch.hs96
-rw-r--r--lib/Data/Aeson/Pointer.hs108
-rw-r--r--stack.yaml2
-rw-r--r--test/data/cases/case3-error.txt1
-rw-r--r--test/doctests.hs4
-rw-r--r--test/examples.hs7
-rw-r--r--test/properties.hs8
10 files changed, 229 insertions, 144 deletions
diff --git a/README.md b/README.md
index 2bc2a79..2c1e8c1 100644
--- a/README.md
+++ b/README.md
@@ -2,6 +2,8 @@ Aeson Diff
==========
[![Build Status][badge]][status]
+[![Hackage](https://img.shields.io/hackage/v/aeson-diff.svg?maxAge=2592000)]()
+[![Hackage-Deps](https://img.shields.io/hackage-deps/v/aeson-diff.svg?maxAge=2592000)]()
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
diff --git a/aeson-diff.cabal b/aeson-diff.cabal
index 5a2979c..24ecb96 100644
--- a/aeson-diff.cabal
+++ b/aeson-diff.cabal
@@ -1,5 +1,5 @@
name: aeson-diff
-version: 1.1.0.0
+version: 1.1.0.2
synopsis: Extract and apply patches to JSON documents.
description:
.
@@ -53,7 +53,7 @@ executable json-diff
, aeson
, aeson-diff
, bytestring
- , optparse-applicative >=0.11 && < 0.13
+ , optparse-applicative
, text
executable json-patch
@@ -64,7 +64,7 @@ executable json-patch
, aeson
, aeson-diff
, bytestring
- , optparse-applicative >=0.11 && < 0.13
+ , optparse-applicative
test-suite properties
default-language: Haskell2010
@@ -99,6 +99,16 @@ test-suite examples
, unordered-containers
, vector
+test-suite doctests
+ default-language: Haskell2010
+ hs-source-dirs: test
+ type: exitcode-stdio-1.0
+ ghc-options: -threaded
+ main-is: doctests.hs
+ build-depends: base
+ , QuickCheck
+ , doctest >= 0.9
+
test-suite hlint-check
default-language: Haskell2010
type: exitcode-stdio-1.0
diff --git a/lib/Data/Aeson/Diff.hs b/lib/Data/Aeson/Diff.hs
index 0de2693..55f006a 100644
--- a/lib/Data/Aeson/Diff.hs
+++ b/lib/Data/Aeson/Diff.hs
@@ -14,7 +14,6 @@ module Data.Aeson.Diff (
Key(..),
Operation(..),
Config(..),
-
-- * Functions
diff,
diff',
@@ -40,19 +39,23 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
import qualified Data.Vector as V
-
-import Data.Vector.Distance
+import Data.Vector.Distance
import Data.Aeson.Patch
import Data.Aeson.Pointer
-data Config = Config
+-- * Configuration
+
+-- | Configuration for the diff algorithm.
+newtype Config = Config
{ configTstBeforeRem :: Bool
}
defaultConfig :: Config
defaultConfig = Config False
+-- * Costs
+
-- | Calculate the cost of an operation.
operationCost :: Operation -> Int
operationCost op =
@@ -64,40 +67,31 @@ operationCost op =
Cpy{} -> 1
Tst{} -> valueSize (changeValue op)
--- | 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
-
+-- | Estimate the size of a JSON 'Value'.
+valueSize :: Value -> Int
+valueSize val = case val of
+ Object o -> sum . fmap valueSize . HM.elems $ o
+ Array a -> V.sum $ V.map valueSize a
+ _ -> 1
-- * Atomic patches
-- | Construct a patch with a single 'Add' operation.
-ins :: Config -> Path -> Value -> [Operation]
-ins cfg p v = [Add (Pointer p) v]
+ins :: Config -> Pointer -> Value -> [Operation]
+ins cfg p v = [Add p v]
-- | Construct a patch with a single 'Rem' operation.
-del :: Config -> Path -> Value -> [Operation]
+del :: Config -> Pointer -> Value -> [Operation]
del Config{..} p v =
if configTstBeforeRem
- then [Tst (Pointer p) v, Rem (Pointer p)]
- else [Rem (Pointer p)]
+ then [Tst p v, Rem p]
+ else [Rem p]
-- | Construct a patch which changes 'Rep' operation.
-rep :: Path -> Value -> [Operation]
-rep p v = [Rep (Pointer p) v]
+rep :: Config -> Pointer -> Value -> [Operation]
+rep Config{..} p v = [Rep p v]
--- * Operations
+-- * Diff
-- | Compare two JSON documents and generate a patch describing the differences.
--
@@ -114,28 +108,28 @@ diff'
-> Value
-> Value
-> Patch
-diff' cfg@Config{..} v v' = Patch (worker [] v v')
+diff' cfg@Config{..} v v' = Patch (worker mempty v v')
where
check :: Monoid m => Bool -> m -> m
check b v = if b then mempty else v
- worker :: Path -> Value -> Value -> [Operation]
+ worker :: Pointer -> Value -> Value -> [Operation]
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) $ rep p v2
- (Number n1, Number n2) -> check (n1 == n2) $ rep p v2
- (String s1, String s2) -> check (s1 == s2) $ rep p v2
+ (Bool b1, Bool b2) -> check (b1 == b2) $ rep cfg p v2
+ (Number n1, Number n2) -> check (n1 == n2) $ rep cfg p v2
+ (String s1, String s2) -> check (s1 == s2) $ rep cfg p v2
-- For structured values of the same type, walk them.
(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, replace v1 with v2.
- _ -> rep p v2
+ _ -> rep cfg p v2
-- Walk the keys in two objects, producing a 'Patch'.
- workObject :: Path -> Object -> Object -> [Operation]
+ workObject :: Pointer -> Object -> Object -> [Operation]
workObject path o1 o2 =
let k1 = HM.keys o1
k2 = HM.keys o2
@@ -144,35 +138,35 @@ diff' cfg@Config{..} v v' = Patch (worker [] v v')
del_keys = filter (not . (`elem` k2)) k1
deletions :: [Operation]
deletions = concatMap
- (\k -> del cfg [OKey k] (fromJust $ HM.lookup k o1))
+ (\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 [OKey k] (fromJust $ HM.lookup k o2))
+ (\k -> ins cfg (Pointer [OKey k]) (fromJust $ HM.lookup k o2))
ins_keys
-- Changes
chg_keys = filter (`elem` k2) k1
changes :: [Operation]
changes = concatMap
- (\k -> worker [OKey k]
+ (\k -> worker (Pointer [OKey k])
(fromJust $ HM.lookup k o1)
(fromJust $ HM.lookup k o2))
chg_keys
- in modifyPath (path <>) <$> (deletions <> insertions <> changes)
+ in modifyPointer (path <>) <$> (deletions <> insertions <> changes)
-- Use an adaption of the Wagner-Fischer algorithm to find the shortest
-- sequence of changes between two JSON arrays.
- workArray :: Path -> Array -> Array -> [Operation]
- workArray path ss tt = fmap (modifyPath (path <>)) . snd . fmap concat $ leastChanges params ss tt
+ workArray :: Pointer -> Array -> Array -> [Operation]
+ workArray path ss tt = fmap (modifyPointer (path <>)) . snd . fmap concat $ leastChanges params ss tt
where
params :: Params Value [Operation] (Sum Int)
params = Params{..}
equivalent = (==)
- delete i = del cfg [AKey i]
- insert i = ins cfg [AKey i]
- substitute i = worker [AKey i]
+ delete i = del cfg (Pointer [AKey i])
+ insert i = ins cfg (Pointer [AKey i])
+ substitute i = worker (Pointer [AKey i])
cost = Sum . sum . fmap operationCost
-- Position is advanced by grouping operations with same "head" index:
-- + groups of many operations advance one
@@ -212,12 +206,14 @@ diff' cfg@Config{..} v v' = Patch (worker [] v v')
| otherwise = 0
pos Tst{changePointer=Pointer path} = 0
+-- * Patching
+
-- | Apply a patch to a JSON document.
patch
:: Patch
-> Value
-> Result Value
-patch (Patch []) val = return val
+patch (Patch []) val = return val
patch (Patch ops) val = foldlM (flip applyOperation) val ops
-- | Apply an 'Operation' to a 'Value'.
@@ -244,28 +240,28 @@ applyOperation op json = case op of
-- - A single 'AKey' inserts at the corresponding location.
-- - Longer 'Paths' traverse if they can and fail otherwise.
applyAdd :: Pointer -> Value -> Value -> Result Value
-applyAdd from@(Pointer path) = go path
+applyAdd pointer = go pointer
where
- go [] val _ =
+ go (Pointer []) val _ =
return val
- go [AKey i] v' (Array v) =
+ go (Pointer [AKey i]) v' (Array v) =
let fn :: Maybe Value -> Result (Maybe Value)
fn _ = return (Just v')
in return (Array $ vInsert i v' v)
- go (AKey i : path) v' (Array v) =
+ go (Pointer (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
+ fn Nothing = cannot "insert" "array" i pointer
+ fn (Just d) = Just <$> go (Pointer path) v' d
in Array <$> vModify i fn v
- go [OKey n] v' (Object m) =
+ go (Pointer [OKey n]) v' (Object m) =
return . Object $ HM.insert n v' m
- go (OKey n : path) v' (Object o) =
+ go (Pointer (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
+ fn Nothing = cannot "insert" "object" n pointer
+ fn (Just d) = Just <$> go (Pointer 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 (Pointer (OKey n : path)) v' array@(Array v)
+ | n == "-" = go (Pointer (AKey (V.length v) : path)) v' array
go path _ v = pointerFailure path v
-- | Apply a 'Rem' operation to a document.
@@ -279,29 +275,29 @@ applyRem from@(Pointer path) = go path
go [] _ = return Null
go [AKey i] d@(Array v) =
let fn :: Maybe Value -> Result (Maybe Value)
- fn Nothing = cannot "delete" "array" i from
+ 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 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 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 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
+ go path value = pointerFailure from value
-- | Apply a 'Rep' operation to a document.
--
@@ -348,15 +344,6 @@ applyTst path v doc = do
-- 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.
-valueSize :: Value -> Int
-valueSize val = case val of
- Object o -> sum . fmap valueSize . HM.elems $ o
- Array a -> V.sum $ V.map valueSize a
- _ -> 1
-
-- | Delete an element in a vector.
vDelete :: Int -> Vector a -> Vector a
vDelete i v =
@@ -411,7 +398,7 @@ hmModify
-> HashMap k v
-> Result (HashMap k v)
hmModify k f m = case f (HM.lookup k m) of
- Error e -> Error e
+ Error e -> Error e
Success Nothing -> return $ HM.delete k m
Success (Just v) -> return $ HM.insert k v m
diff --git a/lib/Data/Aeson/Patch.hs b/lib/Data/Aeson/Patch.hs
index 7315c74..3516f98 100644
--- a/lib/Data/Aeson/Patch.hs
+++ b/lib/Data/Aeson/Patch.hs
@@ -1,11 +1,19 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
-
+{-# LANGUAGE RecordWildCards #-}
-- | Description: Represent RFC 6902 patches.
module Data.Aeson.Patch (
Patch(..),
Operation(..),
+ -- * Modification
+ modifyPointer,
+ modifyPointers,
+ -- * Predicates
+ isAdd,
isRem,
+ isRep,
+ isMov,
+ isCpy,
isTst,
) where
@@ -36,6 +44,12 @@ instance FromJSON Patch where
parsePatch (Array v) = Patch <$> mapM parseJSON (V.toList v)
parsePatch v = typeMismatch "Array" v
+-- | Modify the pointers in the 'Operation's of a 'Patch'.
+--
+-- See 'modifyPointer' for details.
+modifyPointers :: (Pointer -> Pointer) -> Patch -> Patch
+modifyPointers f (Patch ops) = Patch (map (modifyPointer f) ops)
+
-- * Operations
-- | An 'Operation' describes the operations which can appear as part of a JSON
@@ -45,50 +59,42 @@ instance FromJSON Patch where
data Operation
= Add { changePointer :: Pointer, changeValue :: Value }
-- ^ http://tools.ietf.org/html/rfc6902#section-4.1
+ | Cpy { changePointer :: Pointer, fromPointer :: Pointer }
+ -- ^ 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 }
-- ^ 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)
-isRem :: Operation -> Bool
-isRem Rem{} = True
-isRem _ = False
-
-isTst :: Operation -> Bool
-isTst Tst{} = True
-isTst _ = False
-
instance ToJSON Operation where
toJSON (Add p v) = object
[ ("op", "add")
, "path" .= p
, "value" .= v
]
- toJSON (Rem p) = object
- [ ("op", "remove")
+ toJSON (Cpy p f) = object
+ [ ("op", "copy")
, "path" .= p
- ]
- toJSON (Rep p v) = object
- [ ("op", "replace")
- , "path" .= p
- , "value" .= v
+ , "from" .= f
]
toJSON (Mov p f) = object
[ ("op", "move")
, "path" .= p
, "from" .= f
]
- toJSON (Cpy p f) = object
- [ ("op", "copy")
+ toJSON (Rem p) = object
+ [ ("op", "remove")
, "path" .= p
- , "from" .= f
+ ]
+ toJSON (Rep p v) = object
+ [ ("op", "replace")
+ , "path" .= p
+ , "value" .= v
]
toJSON (Tst p v) = object
[ ("op", "test")
@@ -101,11 +107,11 @@ instance FromJSON Operation where
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 "move" *> (Mov <$> v .: "path" <*> v .: "from"))
<|> (op v "remove" *> (Rem <$> v .: "path"))
+ <|> (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))
parse v = typeMismatch "Operation" v
op v n = fixed v "op" (String n)
@@ -115,3 +121,41 @@ instance FromJSON Operation where
then return v'
else mzero
fixed' o n val = (o .: n) >>= \v -> guard (v == n)
+
+-- | Modify the 'Pointer's in an 'Operation'.
+--
+-- If the operation contains multiple pointers (i.e. a 'Mov' or 'Cpy')
+-- then both will be modified.
+modifyPointer :: (Pointer -> Pointer) -> Operation -> Operation
+modifyPointer f op =
+ case op of
+ Add{..} -> op{ changePointer = f changePointer }
+ Cpy{..} -> op{ changePointer = f changePointer, fromPointer = f fromPointer }
+ Mov{..} -> op{ changePointer = f changePointer, fromPointer = f fromPointer }
+ Rem{..} -> op{ changePointer = f changePointer }
+ Rep{..} -> op{ changePointer = f changePointer }
+ Tst{..} -> op{ changePointer = f changePointer }
+
+isAdd :: Operation -> Bool
+isAdd Add{} = True
+isAdd _ = False
+
+isCpy :: Operation -> Bool
+isCpy Cpy{} = True
+isCpy _ = False
+
+isMov :: Operation -> Bool
+isMov Mov{} = True
+isMov _ = False
+
+isRem :: Operation -> Bool
+isRem Rem{} = True
+isRem _ = False
+
+isRep :: Operation -> Bool
+isRep Rep{} = True
+isRep _ = False
+
+isTst :: Operation -> Bool
+isTst Tst{} = True
+isTst _ = False
diff --git a/lib/Data/Aeson/Pointer.hs b/lib/Data/Aeson/Pointer.hs
index 8e16f04..53af6bd 100644
--- a/lib/Data/Aeson/Pointer.hs
+++ b/lib/Data/Aeson/Pointer.hs
@@ -1,14 +1,15 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Description: JSON Pointers as described in RFC 6901.
-
module Data.Aeson.Pointer (
Pointer(..),
Key(..),
- pointerFailure,
- Path,
+ -- * Representing pointers
formatPointer,
+ parsePointer,
+ -- * Using pointers
get,
+ pointerFailure,
) where
import Control.Applicative
@@ -25,7 +26,7 @@ import qualified Data.Vector as V
-- * Patch components
--- | Traverse a single layer of a JSON document.
+-- | Path components to traverse a single layer of a JSON document.
data Key
= OKey Text -- ^ Traverse a 'Value' with an 'Object' constructor.
| AKey Int -- ^ Traverse a 'Value' with an 'Array' constructor.
@@ -64,20 +65,53 @@ newtype Pointer = Pointer { pointerPath :: Path }
deriving (Eq, Show, Monoid)
-- | Format a 'Pointer' as described in RFC 6901.
+--
+-- >>> formatPointer (Pointer [])
+-- ""
+-- >>> formatPointer (Pointer [OKey ""])
+-- "/"
+-- >>> formatPointer (Pointer [OKey " "])
+-- "/ "
+-- >>> formatPointer (Pointer [OKey "foo"])
+-- "/foo"
+-- >>> formatPointer (Pointer [OKey "foo", AKey 0])
+-- "/foo/0"
+-- >>> formatPointer (Pointer [OKey "a/b"])
+-- "/a~1b"
+-- >>> formatPointer (Pointer [OKey "c%d"])
+-- "/c%d"
+-- >>> formatPointer (Pointer [OKey "e^f"])
+-- "/e^f"
+-- >>> formatPointer (Pointer [OKey "g|h"])
+-- "/g|h"
+-- >>> formatPointer (Pointer [OKey "i\\j"])
+-- "/i\\j"
+-- >>> formatPointer (Pointer [OKey "k\"l"])
+-- "/k\"l"
+-- >>> formatPointer (Pointer [OKey "m~n"])
+-- "/m~0n"
formatPointer :: Pointer -> Text
+formatPointer (Pointer []) = ""
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
+-- | Parse a 'Pointer' as described in RFC 6901.
+parsePointer :: Text -> Parser Pointer
+parsePointer t
+ | T.null t = return (Pointer [])
+ | otherwise = Pointer <$> mapM key (drop 1 $ T.splitOn "/" t)
where
- doc = encode value
- pt = encode (Pointer path)
- ty = case key of
- (AKey _) -> "array"
- (OKey _) -> "object"
+ 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)
instance ToJSON Pointer where
toJSON pointer =
@@ -86,28 +120,30 @@ instance ToJSON Pointer where
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 (String t) = parsePointer 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'.
+
+-- | Follow a 'Pointer' through a JSON document as described in RFC 6901.
get :: Pointer -> Value -> Result Value
-get (Pointer p) = get' p
+get (Pointer []) v = return v
+get (Pointer (AKey i : path)) (Array v) =
+ maybe (fail "") return (v V.!? i) >>= get (Pointer path)
+get (Pointer (OKey n : path)) (Object v) =
+ maybe (fail "") return (HM.lookup n v) >>= get (Pointer path)
+get pointer value = pointerFailure pointer value
+
+-- | Report an error while following a pointer.
+pointerFailure :: Pointer -> Value -> Result a
+pointerFailure (Pointer []) value = Error "Cannot follow empty pointer. This is impossible."
+pointerFailure (Pointer path@(key:_)) value =
+ Error . BS.unpack $ "Cannot follow pointer " <> pt <> ". Expected " <> ty <> " but got " <> doc
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
+ doc = encode value
+ pt = encode path
+ ty = case key of
+ (AKey _) -> "array"
+ (OKey _) -> "object"
+
+
+-- $setup
+-- >>> :set -XOverloadedStrings
diff --git a/stack.yaml b/stack.yaml
index c0f13e7..9d03ab4 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: lts-6.7
+resolver: lts-8.2
extra-deps:
- edit-distance-vector-1.0.0.4
flags: {}
diff --git a/test/data/cases/case3-error.txt b/test/data/cases/case3-error.txt
index 867bb35..8171b3c 100644
--- a/test/data/cases/case3-error.txt
+++ b/test/data/cases/case3-error.txt
@@ -1 +1,2 @@
Could not parse patch: when expecting a Array, encountered Object instead
+Error in $: Could not parse patch: expected Array, encountered Object
diff --git a/test/doctests.hs b/test/doctests.hs
new file mode 100644
index 0000000..bd8b9ee
--- /dev/null
+++ b/test/doctests.hs
@@ -0,0 +1,4 @@
+import Test.DocTest
+
+main :: IO ()
+main = doctest ["-ilib", "lib"]
diff --git a/test/examples.hs b/test/examples.hs
index 891f3c0..77cc87b 100644
--- a/test/examples.hs
+++ b/test/examples.hs
@@ -15,7 +15,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Char
import Data.Either
import Data.Functor
-import Data.List (nub)
+import Data.List (isInfixOf, nub)
import Data.Maybe
import Data.Monoid
import System.Directory
@@ -77,8 +77,9 @@ 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 <> "'.")
+ | err `isInfixOf` perr -> success "Patch has expected error."
+ | perr `isInfixOf` err -> success "Patch has expected error."
+ | otherwise -> failure ("Unexpected error `" <> perr <> "' was not '" <> err <> "'.")
(Left err, Right _) ->
failure ("Couldn't load patch: " <> err)
(Right diff, Right res) ->
diff --git a/test/properties.hs b/test/properties.hs
index 5d3a42b..af73ae6 100644
--- a/test/properties.hs
+++ b/test/properties.hs
@@ -26,11 +26,11 @@ import Data.Aeson.Patch
showIt :: Value -> String
showIt = BL.unpack . encode
-data Wellformed a = Wellformed { wellformed :: a }
+newtype Wellformed a = Wellformed { wellformed :: a }
-data AnObject a = AnObject { anObject :: a }
+newtype AnObject a = AnObject { anObject :: a }
-data AnArray a = AnArray { anArray :: a }
+newtype AnArray a = AnArray { anArray :: a }
instance Show (Wellformed Value) where
show = showIt . wellformed
@@ -83,7 +83,7 @@ diffApply f t =
result :: a -> A.Result a -> a
result _ (A.Success a) = a
-result a _ = a
+result a _ = a
-- | Patch extracted from identical documents should be mempty.
prop_diff_id