{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Description: Extract and apply patches on JSON documents.
--
-- This module implements data types and operations to represent the
-- differences between JSON documents (i.e. a patch), to compare JSON documents
-- and extract such a patch, and to apply such a patch to a JSON document.
module Data.Aeson.Diff (
    -- * Patches
    Patch(..),
    Pointer,
    Key(..),
    Operation(..),
    Config(..),
    -- * Functions
    diff,
    diff',
    patch,
    applyOperation,
) where

import           Control.Monad              (unless)
import           Data.Aeson                 (Array, Object, Result(Success, Error), Value(Array, Object, String, Null, Bool, Number))
import qualified Data.Aeson.Key as AesonKey
import qualified Data.Aeson.KeyMap as HM
import           Data.Foldable              (foldlM)
import           Data.List                  (groupBy)
import           Data.Maybe                 (fromJust)
import           Data.Monoid                (Sum(Sum))
import qualified Data.Text                  as T
import           Data.Vector                (Vector)
import qualified Data.Vector                as V
import           Data.Vector.Distance       (Params(Params, equivalent, positionOffset, substitute, insert, delete, cost), leastChanges)

import Data.Aeson.Patch                     (Operation(Add, Cpy, Mov, Rem, Rep, Tst), Patch(Patch), changePointer, changeValue, modifyPointer)
import Data.Aeson.Pointer                   (Key(AKey, OKey), Pointer(Pointer), formatPointer, get, pointerFailure, pointerPath)

-- * Configuration

-- | Configuration for the diff algorithm.
newtype Config = Config
  { Config -> Bool
configTstBeforeRem :: Bool
  }

defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Bool -> Config
Config Bool
False

-- * Costs

-- | Calculate the cost of an operation.
operationCost :: Operation -> Int
operationCost :: Operation -> Int
operationCost Operation
op =
    case Operation
op of
      Add{} -> Value -> Int
valueSize (Operation -> Value
changeValue Operation
op)
      Rem{} -> Int
1
      Rep{} -> Value -> Int
valueSize (Operation -> Value
changeValue Operation
op)
      Mov{} -> Int
1
      Cpy{} -> Int
1
      Tst{} -> Value -> Int
valueSize (Operation -> Value
changeValue Operation
op)

-- | Estimate the size of a JSON 'Value'.
valueSize :: Value -> Int
valueSize :: Value -> Int
valueSize Value
val = case Value
val of
    Object Object
o -> [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> (Object -> [Int]) -> Object -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Int) -> [Value] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Int
valueSize ([Value] -> [Int]) -> (Object -> [Value]) -> Object -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Value]
forall v. KeyMap v -> [v]
HM.elems (Object -> Int) -> Object -> Int
forall a b. (a -> b) -> a -> b
$ Object
o
    Array  Array
a -> Vector Int -> Int
forall a. Num a => Vector a -> a
V.sum (Vector Int -> Int) -> Vector Int -> Int
forall a b. (a -> b) -> a -> b
$ (Value -> Int) -> Array -> Vector Int
forall a b. (a -> b) -> Vector a -> Vector b
V.map Value -> Int
valueSize Array
a
    Value
_        -> Int
1

-- * Atomic patches

-- | Construct a patch with a single 'Add' operation.
ins :: Config -> Pointer -> Value -> [Operation]
ins :: Config -> Pointer -> Value -> [Operation]
ins Config
_cfg Pointer
p Value
v = [Pointer -> Value -> Operation
Add Pointer
p Value
v]

-- | Construct a patch with a single 'Rem' operation.
del :: Config -> Pointer -> Value -> [Operation]
del :: Config -> Pointer -> Value -> [Operation]
del Config{Bool
configTstBeforeRem :: Config -> Bool
configTstBeforeRem :: Bool
configTstBeforeRem} Pointer
p Value
v =
  if Bool
configTstBeforeRem
  then [Pointer -> Value -> Operation
Tst Pointer
p Value
v, Pointer -> Operation
Rem Pointer
p]
  else [Pointer -> Operation
Rem Pointer
p]

-- | Construct a patch which changes 'Rep' operation.
rep :: Config -> Pointer -> Value -> [Operation]
rep :: Config -> Pointer -> Value -> [Operation]
rep Config
_cfg Pointer
p Value
v = [Pointer -> Value -> Operation
Rep Pointer
p Value
v]

-- * Diff

-- | Compare two JSON documents and generate a patch describing the differences.
--
-- Uses the 'defaultConfig'.
diff
  :: Value
  -> Value
  -> Patch
diff :: Value -> Value -> Patch
diff = Config -> Value -> Value -> Patch
diff' Config
defaultConfig

-- | Compare two JSON documents and generate a patch describing the differences.
diff'
    :: Config
    -> Value
    -> Value
    -> Patch
diff' :: Config -> Value -> Value -> Patch
diff' Config
cfg Value
v Value
v' = [Operation] -> Patch
Patch (Pointer -> Value -> Value -> [Operation]
worker Pointer
forall a. Monoid a => a
mempty Value
v Value
v')
  where
    check :: Monoid m => Bool -> m -> m
    check :: forall m. Monoid m => Bool -> m -> m
check Bool
b m
v = if Bool
b then m
forall a. Monoid a => a
mempty else m
v

    worker :: Pointer -> Value -> Value -> [Operation]
    worker :: Pointer -> Value -> Value -> [Operation]
worker Pointer
p Value
v1 Value
v2 = case (Value
v1, Value
v2) of
        -- For atomic values of the same type, emit changes iff they differ.
        (Value
Null,      Value
Null)      -> [Operation]
forall a. Monoid a => a
mempty
        (Bool Bool
b1,   Bool Bool
b2)   -> Bool -> [Operation] -> [Operation]
forall m. Monoid m => Bool -> m -> m
check (Bool
b1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b2) ([Operation] -> [Operation]) -> [Operation] -> [Operation]
forall a b. (a -> b) -> a -> b
$ Config -> Pointer -> Value -> [Operation]
rep Config
cfg Pointer
p Value
v2
        (Number Scientific
n1, Number Scientific
n2) -> Bool -> [Operation] -> [Operation]
forall m. Monoid m => Bool -> m -> m
check (Scientific
n1 Scientific -> Scientific -> Bool
forall a. Eq a => a -> a -> Bool
== Scientific
n2) ([Operation] -> [Operation]) -> [Operation] -> [Operation]
forall a b. (a -> b) -> a -> b
$ Config -> Pointer -> Value -> [Operation]
rep Config
cfg Pointer
p Value
v2
        (String Text
s1, String Text
s2) -> Bool -> [Operation] -> [Operation]
forall m. Monoid m => Bool -> m -> m
check (Text
s1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s2) ([Operation] -> [Operation]) -> [Operation] -> [Operation]
forall a b. (a -> b) -> a -> b
$ Config -> Pointer -> Value -> [Operation]
rep Config
cfg Pointer
p Value
v2

        -- For structured values of the same type, walk them.
        (Array Array
a1,  Array Array
a2)  -> Bool -> [Operation] -> [Operation]
forall m. Monoid m => Bool -> m -> m
check (Array
a1 Array -> Array -> Bool
forall a. Eq a => a -> a -> Bool
== Array
a2) ([Operation] -> [Operation]) -> [Operation] -> [Operation]
forall a b. (a -> b) -> a -> b
$ Pointer -> Array -> Array -> [Operation]
workArray  Pointer
p Array
a1 Array
a2
        (Object Object
o1, Object Object
o2) -> Bool -> [Operation] -> [Operation]
forall m. Monoid m => Bool -> m -> m
check (Object
o1 Object -> Object -> Bool
forall a. Eq a => a -> a -> Bool
== Object
o2) ([Operation] -> [Operation]) -> [Operation] -> [Operation]
forall a b. (a -> b) -> a -> b
$ Pointer -> Object -> Object -> [Operation]
workObject Pointer
p Object
o1 Object
o2

        -- For values of different types, replace v1 with v2.
        (Value, Value)
_                      -> Config -> Pointer -> Value -> [Operation]
rep Config
cfg Pointer
p Value
v2

    -- Walk the keys in two objects, producing a 'Patch'.
    workObject :: Pointer -> Object -> Object -> [Operation]
    workObject :: Pointer -> Object -> Object -> [Operation]
workObject Pointer
path Object
o1 Object
o2 =
        let k1 :: [Key]
k1 = Object -> [Key]
forall v. KeyMap v -> [Key]
HM.keys Object
o1
            k2 :: [Key]
k2 = Object -> [Key]
forall v. KeyMap v -> [Key]
HM.keys Object
o2
            -- Deletions
            del_keys :: [AesonKey.Key]
            del_keys :: [Key]
del_keys = (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Key -> Bool) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> [Key] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key]
k2)) [Key]
k1
            deletions :: [Operation]
            deletions :: [Operation]
deletions = (Key -> [Operation]) -> [Key] -> [Operation]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                (\Key
k -> Config -> Pointer -> Value -> [Operation]
del Config
cfg (Path -> Pointer
Pointer [Key -> Key
OKey Key
k]) (Maybe Value -> Value
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
HM.lookup Key
k Object
o1))
                [Key]
del_keys
            -- Insertions
            ins_keys :: [Key]
ins_keys = (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Key -> Bool) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> [Key] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key]
k1)) [Key]
k2
            insertions :: [Operation]
            insertions :: [Operation]
insertions = (Key -> [Operation]) -> [Key] -> [Operation]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                (\Key
k -> Config -> Pointer -> Value -> [Operation]
ins Config
cfg (Path -> Pointer
Pointer [Key -> Key
OKey Key
k]) (Maybe Value -> Value
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
HM.lookup Key
k Object
o2))
                [Key]
ins_keys
            -- Changes
            chg_keys :: [Key]
chg_keys = (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Key -> [Key] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key]
k2) [Key]
k1
            changes :: [Operation]
            changes :: [Operation]
changes = (Key -> [Operation]) -> [Key] -> [Operation]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                (\Key
k -> Pointer -> Value -> Value -> [Operation]
worker (Path -> Pointer
Pointer [Key -> Key
OKey Key
k])
                    (Maybe Value -> Value
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
HM.lookup Key
k Object
o1)
                    (Maybe Value -> Value
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
HM.lookup Key
k Object
o2))
                [Key]
chg_keys
        in (Pointer -> Pointer) -> Operation -> Operation
modifyPointer (Pointer
path Pointer -> Pointer -> Pointer
forall a. Semigroup a => a -> a -> a
<>) (Operation -> Operation) -> [Operation] -> [Operation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Operation]
deletions [Operation] -> [Operation] -> [Operation]
forall a. Semigroup a => a -> a -> a
<> [Operation]
insertions [Operation] -> [Operation] -> [Operation]
forall a. Semigroup a => a -> a -> a
<> [Operation]
changes)

    -- Use an adaption of the Wagner-Fischer algorithm to find the shortest
    -- sequence of changes between two JSON arrays.
    workArray :: Pointer -> Array -> Array -> [Operation]
    workArray :: Pointer -> Array -> Array -> [Operation]
workArray Pointer
path Array
ss Array
tt = (Operation -> Operation) -> [Operation] -> [Operation]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Pointer -> Pointer) -> Operation -> Operation
modifyPointer (Pointer
path Pointer -> Pointer -> Pointer
forall a. Semigroup a => a -> a -> a
<>)) ([Operation] -> [Operation])
-> ((Sum Int, [[Operation]]) -> [Operation])
-> (Sum Int, [[Operation]])
-> [Operation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sum Int, [Operation]) -> [Operation]
forall a b. (a, b) -> b
snd ((Sum Int, [Operation]) -> [Operation])
-> ((Sum Int, [[Operation]]) -> (Sum Int, [Operation]))
-> (Sum Int, [[Operation]])
-> [Operation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Operation]] -> [Operation])
-> (Sum Int, [[Operation]]) -> (Sum Int, [Operation])
forall a b. (a -> b) -> (Sum Int, a) -> (Sum Int, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Operation]] -> [Operation]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Sum Int, [[Operation]]) -> [Operation])
-> (Sum Int, [[Operation]]) -> [Operation]
forall a b. (a -> b) -> a -> b
$ Params Value [Operation] (Sum Int)
-> Array -> Array -> (Sum Int, [[Operation]])
forall c v o.
(Monoid c, Ord c) =>
Params v o c -> Vector v -> Vector v -> (c, [o])
leastChanges Params Value [Operation] (Sum Int)
params Array
ss Array
tt
      where
        params :: Params Value [Operation] (Sum Int)
        params :: Params Value [Operation] (Sum Int)
params = Params{Value -> Value -> Bool
equivalent :: Value -> Value -> Bool
equivalent :: Value -> Value -> Bool
equivalent, Int -> Value -> [Operation]
delete :: Int -> Value -> [Operation]
delete :: Int -> Value -> [Operation]
delete, Int -> Value -> [Operation]
insert :: Int -> Value -> [Operation]
insert :: Int -> Value -> [Operation]
insert, Int -> Value -> Value -> [Operation]
substitute :: Int -> Value -> Value -> [Operation]
substitute :: Int -> Value -> Value -> [Operation]
substitute, [Operation] -> Sum Int
cost :: [Operation] -> Sum Int
cost :: [Operation] -> Sum Int
cost, [Operation] -> Int
positionOffset :: [Operation] -> Int
positionOffset :: [Operation] -> Int
positionOffset}
        equivalent :: Value -> Value -> Bool
        equivalent :: Value -> Value -> Bool
equivalent = Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
(==)
        delete :: Int -> Value -> [Operation]
delete Int
i = Config -> Pointer -> Value -> [Operation]
del Config
cfg (Path -> Pointer
Pointer [Int -> Key
AKey Int
i])
        insert :: Int -> Value -> [Operation]
insert Int
i = Config -> Pointer -> Value -> [Operation]
ins Config
cfg (Path -> Pointer
Pointer [Int -> Key
AKey Int
i])
        substitute :: Int -> Value -> Value -> [Operation]
substitute Int
i = Pointer -> Value -> Value -> [Operation]
worker (Path -> Pointer
Pointer [Int -> Key
AKey Int
i])
        cost :: [Operation] -> Sum Int
        cost :: [Operation] -> Sum Int
cost = Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int) -> ([Operation] -> Int) -> [Operation] -> Sum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> ([Operation] -> [Int]) -> [Operation] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Operation -> Int) -> [Operation] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Operation -> Int
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 :: [Operation] -> Int
positionOffset = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> ([Operation] -> [Int]) -> [Operation] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Operation] -> Int) -> [[Operation]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Operation] -> Int
adv ([[Operation]] -> [Int])
-> ([Operation] -> [[Operation]]) -> [Operation] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Operation -> Operation -> Bool) -> [Operation] -> [[Operation]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy Operation -> Operation -> Bool
related
        related :: Operation -> Operation -> Bool
        related :: Operation -> Operation -> Bool
related Operation
o1 Operation
o2 =
            let p1 :: Path
p1 = Pointer -> Path
pointerPath (Operation -> Pointer
changePointer Operation
o1)
                p2 :: Path
p2 = Pointer -> Path
pointerPath (Operation -> Pointer
changePointer Operation
o2)
            in case (Path
p1, Path
p2) of
                 ([Key
_], [Key
_]) -> Bool
False
                 (Key
i1:Path
_, Key
i2:Path
_) | Key
i1 Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
i2  -> Bool
True
                              | Bool
otherwise -> Bool
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 :: [Operation] -> Int
adv [Operation
op]
            | (Path -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Path -> Int) -> (Operation -> Path) -> Operation -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pointer -> Path
pointerPath (Pointer -> Path) -> (Operation -> Pointer) -> Operation -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Operation -> Pointer
changePointer (Operation -> Int) -> Operation -> Int
forall a b. (a -> b) -> a -> b
$ Operation
op) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Operation -> Int
pos Operation
op
        adv [Operation]
_    = Int
1
        pos :: Operation -> Int
        pos :: Operation -> Int
pos Rem{changePointer :: Operation -> Pointer
changePointer=Pointer Path
path}
            | Path -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Path
path Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Int
0
            | Bool
otherwise        = Int
0
        pos Add{changePointer :: Operation -> Pointer
changePointer=Pointer Path
path}
            | Path -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Path
path Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Int
1
            | Bool
otherwise        = Int
0
        pos Rep{changePointer :: Operation -> Pointer
changePointer=Pointer Path
path}
            | Path -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Path
path Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Int
1
            | Bool
otherwise        = Int
0
        pos Cpy{changePointer :: Operation -> Pointer
changePointer=Pointer Path
path}
            | Path -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Path
path Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Int
1
            | Bool
otherwise        = Int
0
        pos Mov{changePointer :: Operation -> Pointer
changePointer=Pointer Path
path}
            | Path -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Path
path Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Int
1
            | Bool
otherwise        = Int
0
        pos Tst{changePointer :: Operation -> Pointer
changePointer=Pointer Path
_path} = Int
0

-- * Patching

-- | Apply a patch to a JSON document.
patch
    :: Patch
    -> Value
    -> Result Value
patch :: Patch -> Value -> Result Value
patch (Patch []) Value
val  = Value -> Result Value
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
val
patch (Patch [Operation]
ops) Value
val = (Value -> Operation -> Result Value)
-> Value -> [Operation] -> Result Value
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ((Operation -> Value -> Result Value)
-> Value -> Operation -> Result Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip Operation -> Value -> Result Value
applyOperation) Value
val [Operation]
ops

-- | Apply an 'Operation' to a 'Value'.
applyOperation
    :: Operation
    -> Value
    -> Result Value
applyOperation :: Operation -> Value -> Result Value
applyOperation Operation
op Value
json = case Operation
op of
    Add Pointer
path Value
v'   -> Pointer -> Value -> Value -> Result Value
applyAdd Pointer
path Value
v' Value
json
    Rem Pointer
path      -> Pointer -> Value -> Result Value
applyRem Pointer
path    Value
json
    Rep Pointer
path Value
v'   -> Pointer -> Value -> Value -> Result Value
applyRep Pointer
path Value
v' Value
json
    Tst Pointer
path Value
v    -> Pointer -> Value -> Value -> Result Value
applyTst Pointer
path Value
v  Value
json
    Cpy Pointer
path Pointer
from -> Pointer -> Pointer -> Value -> Result Value
applyCpy Pointer
path Pointer
from Value
json
    Mov Pointer
path Pointer
from -> Pointer -> Pointer -> Value -> Result Value
applyMov Pointer
path Pointer
from Value
json

-- | 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 :: Pointer -> Value -> Value -> Result Value
applyAdd :: Pointer -> Value -> Value -> Result Value
applyAdd Pointer
pointer = Pointer -> Value -> Value -> Result Value
go Pointer
pointer
  where
    go :: Pointer -> Value -> Value -> Result Value
go (Pointer []) Value
val Value
_ =
        Value -> Result Value
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
val
    go (Pointer [AKey Int
i]) Value
v' (Array Array
v) =
        Value -> Result Value
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return (Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ Int -> Value -> Array -> Array
forall a. Int -> a -> Vector a -> Vector a
vInsert Int
i Value
v' Array
v)
    go (Pointer (AKey Int
i : Path
path)) Value
v' (Array Array
v) =
        let fn :: Maybe Value -> Result (Maybe Value)
            fn :: Maybe Value -> Result (Maybe Value)
fn Maybe Value
Nothing  = String -> String -> Int -> Pointer -> Result (Maybe Value)
forall ix a.
Show ix =>
String -> String -> ix -> Pointer -> Result a
cannot String
"insert" String
"array" Int
i Pointer
pointer
            fn (Just Value
d) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Result Value -> Result (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pointer -> Value -> Value -> Result Value
go (Path -> Pointer
Pointer Path
path) Value
v' Value
d
        in Array -> Value
Array (Array -> Value) -> Result Array -> Result Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> (Maybe Value -> Result (Maybe Value)) -> Array -> Result Array
forall a.
Int
-> (Maybe a -> Result (Maybe a)) -> Vector a -> Result (Vector a)
vModify Int
i Maybe Value -> Result (Maybe Value)
fn Array
v
    go (Pointer [OKey Key
n]) Value
v' (Object Object
m) =
        Value -> Result Value
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Result Value)
-> (Object -> Value) -> Object -> Result Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
Object (Object -> Result Value) -> Object -> Result Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
HM.insert Key
n Value
v' Object
m
    go (Pointer (OKey Key
n : Path
path)) Value
v' (Object Object
o) =
        let fn :: Maybe Value -> Result (Maybe Value)
            fn :: Maybe Value -> Result (Maybe Value)
fn Maybe Value
Nothing  = String -> String -> Key -> Pointer -> Result (Maybe Value)
forall ix a.
Show ix =>
String -> String -> ix -> Pointer -> Result a
cannot String
"insert" String
"object" Key
n Pointer
pointer
            fn (Just Value
d) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Result Value -> Result (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pointer -> Value -> Value -> Result Value
go (Path -> Pointer
Pointer Path
path) Value
v' Value
d
        in Object -> Value
Object (Object -> Value) -> Result Object -> Result Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key
-> (Maybe Value -> Result (Maybe Value)) -> Object -> Result Object
forall v.
Key
-> (Maybe v -> Result (Maybe v)) -> KeyMap v -> Result (KeyMap v)
hmModify Key
n Maybe Value -> Result (Maybe Value)
fn Object
o
    go (Pointer (OKey Key
n : Path
path)) Value
v' array :: Value
array@(Array Array
v)
        | Key
n Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
"-" = Pointer -> Value -> Value -> Result Value
go (Path -> Pointer
Pointer (Int -> Key
AKey (Array -> Int
forall a. Vector a -> Int
V.length Array
v) Key -> Path -> Path
forall a. a -> [a] -> [a]
: Path
path)) Value
v' Value
array
    go Pointer
path Value
_ Value
v = Pointer -> Value -> Result Value
forall a. Pointer -> Value -> Result a
pointerFailure Pointer
path Value
v

-- | Apply a 'Rem' operation to a document.
--
-- http://tools.ietf.org/html/rfc6902#section-4.2
--
-- - The target location MUST exist.
applyRem :: Pointer -> Value -> Result Value
applyRem :: Pointer -> Value -> Result Value
applyRem from :: Pointer
from@(Pointer Path
path) = Path -> Value -> Result Value
go Path
path
  where
    go :: Path -> Value -> Result Value
go [] Value
_ = Value -> Result Value
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
Null
    go [AKey Int
i] (Array Array
v) =
        let fn :: Maybe Value -> Result (Maybe Value)
            fn :: Maybe Value -> Result (Maybe Value)
fn Maybe Value
Nothing  = String -> String -> Int -> Pointer -> Result (Maybe Value)
forall ix a.
Show ix =>
String -> String -> ix -> Pointer -> Result a
cannot String
"delete" String
"array" Int
i Pointer
from
            fn (Just Value
_) = Maybe Value -> Result (Maybe Value)
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Value
forall a. Maybe a
Nothing
        in Array -> Value
Array (Array -> Value) -> Result Array -> Result Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> (Maybe Value -> Result (Maybe Value)) -> Array -> Result Array
forall a.
Int
-> (Maybe a -> Result (Maybe a)) -> Vector a -> Result (Vector a)
vModify Int
i Maybe Value -> Result (Maybe Value)
fn Array
v
    go (AKey Int
i : Path
path) (Array Array
v) =
        let fn :: Maybe Value -> Result (Maybe Value)
            fn :: Maybe Value -> Result (Maybe Value)
fn Maybe Value
Nothing  = String -> String -> Int -> Pointer -> Result (Maybe Value)
forall ix a.
Show ix =>
String -> String -> ix -> Pointer -> Result a
cannot String
"traverse" String
"array" Int
i Pointer
from
            fn (Just Value
o) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Result Value -> Result (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path -> Value -> Result Value
go Path
path Value
o
        in Array -> Value
Array (Array -> Value) -> Result Array -> Result Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> (Maybe Value -> Result (Maybe Value)) -> Array -> Result Array
forall a.
Int
-> (Maybe a -> Result (Maybe a)) -> Vector a -> Result (Vector a)
vModify Int
i Maybe Value -> Result (Maybe Value)
fn Array
v
    go [OKey Key
n] (Object Object
m) =
        let fn :: Maybe Value -> Result (Maybe Value)
            fn :: Maybe Value -> Result (Maybe Value)
fn Maybe Value
Nothing  = String -> String -> Key -> Pointer -> Result (Maybe Value)
forall ix a.
Show ix =>
String -> String -> ix -> Pointer -> Result a
cannot String
"delete" String
"object" Key
n Pointer
from
            fn (Just Value
_) = Maybe Value -> Result (Maybe Value)
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Value
forall a. Maybe a
Nothing
        in Object -> Value
Object (Object -> Value) -> Result Object -> Result Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key
-> (Maybe Value -> Result (Maybe Value)) -> Object -> Result Object
forall v.
Key
-> (Maybe v -> Result (Maybe v)) -> KeyMap v -> Result (KeyMap v)
hmModify Key
n Maybe Value -> Result (Maybe Value)
fn Object
m
    go (OKey Key
n : Path
path) (Object Object
m) =
        let fn :: Maybe Value -> Result (Maybe Value)
            fn :: Maybe Value -> Result (Maybe Value)
fn Maybe Value
Nothing  = String -> String -> Key -> Pointer -> Result (Maybe Value)
forall ix a.
Show ix =>
String -> String -> ix -> Pointer -> Result a
cannot String
"traverse" String
"object" Key
n Pointer
from
            fn (Just Value
o) = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Result Value -> Result (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path -> Value -> Result Value
go Path
path Value
o
        in Object -> Value
Object (Object -> Value) -> Result Object -> Result Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key
-> (Maybe Value -> Result (Maybe Value)) -> Object -> Result Object
forall v.
Key
-> (Maybe v -> Result (Maybe v)) -> KeyMap v -> Result (KeyMap v)
hmModify Key
n Maybe Value -> Result (Maybe Value)
fn Object
m
    -- Dodgy hack for "-" key which means "the end of the array".
    go (OKey Key
n : Path
path) array :: Value
array@(Array Array
v)
        | Key
n Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
"-" = Path -> Value -> Result Value
go (Int -> Key
AKey (Array -> Int
forall a. Vector a -> Int
V.length Array
v) Key -> Path -> Path
forall a. a -> [a] -> [a]
: Path
path) Value
array
    -- Type mismatch: clearly the thing we're deleting isn't here.
    go Path
_path Value
value = Pointer -> Value -> Result Value
forall a. Pointer -> Value -> Result a
pointerFailure Pointer
from Value
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 :: Pointer -> Value -> Value -> Result Value
applyRep :: Pointer -> Value -> Value -> Result Value
applyRep Pointer
from Value
v Value
doc = Pointer -> Value -> Result Value
applyRem Pointer
from Value
doc Result Value -> (Value -> Result Value) -> Result Value
forall a b. Result a -> (a -> Result b) -> Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pointer -> Value -> Value -> Result Value
applyAdd Pointer
from Value
v

-- | Apply a 'Mov' operation to a document.
--
-- http://tools.ietf.org/html/rfc6902#section-4.4
applyMov :: Pointer -> Pointer -> Value -> Result Value
applyMov :: Pointer -> Pointer -> Value -> Result Value
applyMov Pointer
path Pointer
from Value
doc = do
  Value
v <- Pointer -> Value -> Result Value
get Pointer
from Value
doc
  Pointer -> Value -> Result Value
applyRem Pointer
from Value
doc Result Value -> (Value -> Result Value) -> Result Value
forall a b. Result a -> (a -> Result b) -> Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pointer -> Value -> Value -> Result Value
applyAdd Pointer
path Value
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 :: Pointer -> Pointer -> Value -> Result Value
applyCpy :: Pointer -> Pointer -> Value -> Result Value
applyCpy Pointer
path Pointer
from Value
doc = do
  Value
v <- Pointer -> Value -> Result Value
get Pointer
from Value
doc
  Pointer -> Value -> Value -> Result Value
applyAdd Pointer
path Value
v Value
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 :: Pointer -> Value -> Value -> Result Value
applyTst :: Pointer -> Value -> Value -> Result Value
applyTst Pointer
path Value
v Value
doc = do
    Value
v' <- Pointer -> Value -> Result Value
get Pointer
path Value
doc
    Bool -> Result () -> Result ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
v') (String -> Result ()
forall a. String -> Result a
Error (String -> Result ()) -> (Text -> String) -> Text -> Result ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Result ()) -> Text -> Result ()
forall a b. (a -> b) -> a -> b
$ Text
"Element at \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Pointer -> Text
formatPointer Pointer
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" fails test.")
    Value -> Result Value
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
doc

-- * 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.Aeson.KeyMap" modules.

-- | Delete an element in a vector.
vDelete :: Int -> Vector a -> Vector a
vDelete :: forall a. Int -> Vector a -> Vector a
vDelete Int
i Vector a
v =
    let l :: Int
l = Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
v
    in Int -> Int -> Vector a -> Vector a
forall a. Int -> Int -> Vector a -> Vector a
V.slice Int
0 Int
i Vector a
v Vector a -> Vector a -> Vector a
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Vector a -> Vector a
forall a. Int -> Int -> Vector a -> Vector a
V.slice (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Vector a
v

-- | Insert an element into a vector.
vInsert :: Int -> a -> Vector a -> Vector a
vInsert :: forall a. Int -> a -> Vector a -> Vector a
vInsert Int
i a
a Vector a
v
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0          = a -> Vector a -> Vector a
forall a. a -> Vector a -> Vector a
V.cons a
a Vector a
v
    | Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i = Vector a -> a -> Vector a
forall a. Vector a -> a -> Vector a
V.snoc Vector a
v a
a
    | Bool
otherwise       = Int -> Int -> Vector a -> Vector a
forall a. Int -> Int -> Vector a -> Vector a
V.slice Int
0 Int
i Vector a
v
                      Vector a -> Vector a -> Vector a
forall a. Semigroup a => a -> a -> a
<> a -> Vector a
forall a. a -> Vector a
V.singleton a
a
                      Vector a -> Vector a -> Vector a
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Vector a -> Vector a
forall a. Int -> Int -> Vector a -> Vector a
V.slice Int
i (Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Vector a
v

-- | Modify the element at an index in a 'Vector'.
--
-- The function is passed the value at index @i@, or 'Nothing' if there is no
-- such element. The function should return 'Nothing' if it wants to have no
-- value corresponding to the index, or 'Just' if it wants a value.
--
-- Depending on the vector and the function, we will either:
--
-- - leave the vector unchanged;
-- - 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 :: forall a.
Int
-> (Maybe a -> Result (Maybe a)) -> Vector a -> Result (Vector a)
vModify Int
i Maybe a -> Result (Maybe a)
f Vector a
v =
    let a :: Maybe a
a = Vector a
v Vector a -> Int -> Maybe a
forall a. Vector a -> Int -> Maybe a
V.!? Int
i
        a' :: Result (Maybe a)
a' = Maybe a -> Result (Maybe a)
f Maybe a
a
    in case (Maybe a
a, Result (Maybe a)
a') of
        (Maybe a
Nothing, Success Maybe a
Nothing ) -> Vector a -> Result (Vector a)
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return Vector a
v
        (Just a
_ , Success Maybe a
Nothing ) -> Vector a -> Result (Vector a)
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Vector a -> Vector a
forall a. Int -> Vector a -> Vector a
vDelete Int
i Vector a
v)
        (Maybe a
Nothing, Success (Just a
n)) -> Vector a -> Result (Vector a)
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> a -> Vector a -> Vector a
forall a. Int -> a -> Vector a -> Vector a
vInsert Int
i a
n Vector a
v)
        (Just a
_ , Success (Just a
n)) -> Vector a -> Result (Vector a)
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector a -> Vector (Int, a) -> Vector a
forall a. Vector a -> Vector (Int, a) -> Vector a
V.update Vector a
v ((Int, a) -> Vector (Int, a)
forall a. a -> Vector a
V.singleton (Int
i, a
n)))
        (Maybe a
_      , Error   String
e       ) -> String -> Result (Vector a)
forall a. String -> Result a
Error String
e

-- | Modify the value associated with a key in a 'KeyMap'.
--
-- The function is passed the value defined for @k@, or 'Nothing'. If the
-- function returns 'Nothing', the key and value are deleted from the map;
-- otherwise the value replaces the existing value in the returned map.
hmModify
    :: AesonKey.Key
    -> (Maybe v -> Result (Maybe v))
    -> HM.KeyMap v
    -> Result (HM.KeyMap v)
hmModify :: forall v.
Key
-> (Maybe v -> Result (Maybe v)) -> KeyMap v -> Result (KeyMap v)
hmModify Key
k Maybe v -> Result (Maybe v)
f KeyMap v
m = case Maybe v -> Result (Maybe v)
f (Key -> KeyMap v -> Maybe v
forall v. Key -> KeyMap v -> Maybe v
HM.lookup Key
k KeyMap v
m) of
    Error String
e          -> String -> Result (KeyMap v)
forall a. String -> Result a
Error String
e
    Success Maybe v
Nothing  -> KeyMap v -> Result (KeyMap v)
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return (KeyMap v -> Result (KeyMap v)) -> KeyMap v -> Result (KeyMap v)
forall a b. (a -> b) -> a -> b
$ Key -> KeyMap v -> KeyMap v
forall v. Key -> KeyMap v -> KeyMap v
HM.delete Key
k KeyMap v
m
    Success (Just v
v) -> KeyMap v -> Result (KeyMap v)
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return (KeyMap v -> Result (KeyMap v)) -> KeyMap v -> Result (KeyMap v)
forall a b. (a -> b) -> a -> b
$ Key -> v -> KeyMap v -> KeyMap v
forall v. Key -> v -> KeyMap v -> KeyMap v
HM.insert Key
k v
v KeyMap 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 :: forall ix a.
Show ix =>
String -> String -> ix -> Pointer -> Result a
cannot String
op String
ty ix
ix Pointer
p =
    String -> Result a
forall a. String -> Result a
Error (String
"Cannot " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
op String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" missing " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ty String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" member at index "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ix -> String
forall a. Show a => a -> String
show ix
ix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" in pointer \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Pointer -> Text
formatPointer Pointer
p) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\".")