{-# LANGUAGE DeriveGeneric              #-}
{-# 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

import           Control.Applicative ((<|>))
import           Control.Monad (mzero)
import           Data.Aeson ((.:), (.=), FromJSON(parseJSON), ToJSON(toJSON), encode)
import           Data.Aeson.Types (Value(Array, Object, String), modifyFailure, object, typeMismatch)
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.Vector                as V
import           GHC.Generics               (Generic)

import Data.Aeson.Pointer (Pointer)

-- * Patches

-- | Describes the changes between two JSON documents.
newtype Patch = Patch
    { Patch -> [Operation]
patchOperations :: [Operation] }
  deriving (Patch -> Patch -> Bool
(Patch -> Patch -> Bool) -> (Patch -> Patch -> Bool) -> Eq Patch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Patch -> Patch -> Bool
$c/= :: Patch -> Patch -> Bool
== :: Patch -> Patch -> Bool
$c== :: Patch -> Patch -> Bool
Eq, Int -> Patch -> ShowS
[Patch] -> ShowS
Patch -> String
(Int -> Patch -> ShowS)
-> (Patch -> String) -> ([Patch] -> ShowS) -> Show Patch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Patch] -> ShowS
$cshowList :: [Patch] -> ShowS
show :: Patch -> String
$cshow :: Patch -> String
showsPrec :: Int -> Patch -> ShowS
$cshowsPrec :: Int -> Patch -> ShowS
Show, b -> Patch -> Patch
NonEmpty Patch -> Patch
Patch -> Patch -> Patch
(Patch -> Patch -> Patch)
-> (NonEmpty Patch -> Patch)
-> (forall b. Integral b => b -> Patch -> Patch)
-> Semigroup Patch
forall b. Integral b => b -> Patch -> Patch
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Patch -> Patch
$cstimes :: forall b. Integral b => b -> Patch -> Patch
sconcat :: NonEmpty Patch -> Patch
$csconcat :: NonEmpty Patch -> Patch
<> :: Patch -> Patch -> Patch
$c<> :: Patch -> Patch -> Patch
Semigroup, Semigroup Patch
Patch
Semigroup Patch
-> Patch
-> (Patch -> Patch -> Patch)
-> ([Patch] -> Patch)
-> Monoid Patch
[Patch] -> Patch
Patch -> Patch -> Patch
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Patch] -> Patch
$cmconcat :: [Patch] -> Patch
mappend :: Patch -> Patch -> Patch
$cmappend :: Patch -> Patch -> Patch
mempty :: Patch
$cmempty :: Patch
$cp1Monoid :: Semigroup Patch
Monoid, (forall x. Patch -> Rep Patch x)
-> (forall x. Rep Patch x -> Patch) -> Generic Patch
forall x. Rep Patch x -> Patch
forall x. Patch -> Rep Patch x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Patch x -> Patch
$cfrom :: forall x. Patch -> Rep Patch x
Generic)

instance ToJSON Patch where
    toJSON :: Patch -> Value
toJSON (Patch [Operation]
ops) = [Operation] -> Value
forall a. ToJSON a => a -> Value
toJSON [Operation]
ops

instance FromJSON Patch where
    parseJSON :: Value -> Parser Patch
parseJSON = ShowS -> Parser Patch -> Parser Patch
forall a. ShowS -> Parser a -> Parser a
modifyFailure (String
"Could not parse patch: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ) (Parser Patch -> Parser Patch)
-> (Value -> Parser Patch) -> Value -> Parser Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Patch
parsePatch
      where
        parsePatch :: Value -> Parser Patch
parsePatch (Array Array
v) = [Operation] -> Patch
Patch ([Operation] -> Patch) -> Parser [Operation] -> Parser Patch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser Operation) -> [Value] -> Parser [Operation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Parser Operation
forall a. FromJSON a => Value -> Parser a
parseJSON (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
v)
        parsePatch Value
v = String -> Value -> Parser Patch
forall a. String -> Value -> Parser a
typeMismatch String
"Array" Value
v

-- | Modify the pointers in the 'Operation's of a 'Patch'.
--
-- See 'modifyPointer' for details.
modifyPointers :: (Pointer -> Pointer) -> Patch -> Patch
modifyPointers :: (Pointer -> Pointer) -> Patch -> Patch
modifyPointers Pointer -> Pointer
f (Patch [Operation]
ops) = [Operation] -> Patch
Patch ((Operation -> Operation) -> [Operation] -> [Operation]
forall a b. (a -> b) -> [a] -> [b]
map ((Pointer -> Pointer) -> Operation -> Operation
modifyPointer Pointer -> Pointer
f) [Operation]
ops)

-- * Operations

-- | An 'Operation' describes the operations which can appear as part of a JSON
-- Patch.
--
-- See RFC 6902 Section 4 <http://tools.ietf.org/html/rfc6902#section-4>.
data Operation
    = Add { Operation -> Pointer
changePointer :: Pointer, Operation -> Value
changeValue :: Value }
    -- ^ http://tools.ietf.org/html/rfc6902#section-4.1
    | Cpy { changePointer :: Pointer, Operation -> 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
    | Tst { changePointer :: Pointer, changeValue :: Value }
    -- ^ http://tools.ietf.org/html/rfc6902#section-4.6
  deriving (Operation -> Operation -> Bool
(Operation -> Operation -> Bool)
-> (Operation -> Operation -> Bool) -> Eq Operation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Operation -> Operation -> Bool
$c/= :: Operation -> Operation -> Bool
== :: Operation -> Operation -> Bool
$c== :: Operation -> Operation -> Bool
Eq, Int -> Operation -> ShowS
[Operation] -> ShowS
Operation -> String
(Int -> Operation -> ShowS)
-> (Operation -> String)
-> ([Operation] -> ShowS)
-> Show Operation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Operation] -> ShowS
$cshowList :: [Operation] -> ShowS
show :: Operation -> String
$cshow :: Operation -> String
showsPrec :: Int -> Operation -> ShowS
$cshowsPrec :: Int -> Operation -> ShowS
Show, (forall x. Operation -> Rep Operation x)
-> (forall x. Rep Operation x -> Operation) -> Generic Operation
forall x. Rep Operation x -> Operation
forall x. Operation -> Rep Operation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Operation x -> Operation
$cfrom :: forall x. Operation -> Rep Operation x
Generic)

instance ToJSON Operation where
    toJSON :: Operation -> Value
toJSON (Add Pointer
p Value
v) = [Pair] -> Value
object
        [ (Key
"op", Value
"add")
        , Key
"path"  Key -> Pointer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Pointer
p
        , Key
"value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
v
        ]
    toJSON (Cpy Pointer
p Pointer
f) = [Pair] -> Value
object
        [ (Key
"op", Value
"copy")
        , Key
"path" Key -> Pointer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Pointer
p
        , Key
"from" Key -> Pointer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Pointer
f
        ]
    toJSON (Mov Pointer
p Pointer
f) = [Pair] -> Value
object
        [ (Key
"op", Value
"move")
        , Key
"path" Key -> Pointer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Pointer
p
        , Key
"from" Key -> Pointer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Pointer
f
        ]
    toJSON (Rem Pointer
p) = [Pair] -> Value
object
        [ (Key
"op", Value
"remove")
        , Key
"path" Key -> Pointer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Pointer
p
        ]
    toJSON (Rep Pointer
p Value
v) = [Pair] -> Value
object
        [ (Key
"op", Value
"replace")
        , Key
"path"  Key -> Pointer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Pointer
p
        , Key
"value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
v
        ]
    toJSON (Tst Pointer
p Value
v) = [Pair] -> Value
object
        [ (Key
"op", Value
"test")
        , Key
"path" Key -> Pointer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Pointer
p
        , Key
"value" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
v
        ]

instance FromJSON Operation where
    parseJSON :: Value -> Parser Operation
parseJSON = Value -> Parser Operation
parse
      where
        parse :: Value -> Parser Operation
parse o :: Value
o@(Object Object
v)
            =   (Object -> Text -> Parser Value
op Object
v Text
"add"     Parser Value -> Parser Operation -> Parser Operation
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Pointer -> Value -> Operation
Add (Pointer -> Value -> Operation)
-> Parser Pointer -> Parser (Value -> Operation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Pointer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"path" Parser (Value -> Operation) -> Parser Value -> Parser Operation
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"))
            Parser Operation -> Parser Operation -> Parser Operation
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Object -> Text -> Parser Value
op Object
v Text
"copy"    Parser Value -> Parser Operation -> Parser Operation
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Pointer -> Pointer -> Operation
Cpy (Pointer -> Pointer -> Operation)
-> Parser Pointer -> Parser (Pointer -> Operation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Pointer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"path" Parser (Pointer -> Operation) -> Parser Pointer -> Parser Operation
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Pointer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"from"))
            Parser Operation -> Parser Operation -> Parser Operation
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Object -> Text -> Parser Value
op Object
v Text
"move"    Parser Value -> Parser Operation -> Parser Operation
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Pointer -> Pointer -> Operation
Mov (Pointer -> Pointer -> Operation)
-> Parser Pointer -> Parser (Pointer -> Operation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Pointer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"path" Parser (Pointer -> Operation) -> Parser Pointer -> Parser Operation
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Pointer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"from"))
            Parser Operation -> Parser Operation -> Parser Operation
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Object -> Text -> Parser Value
op Object
v Text
"remove"  Parser Value -> Parser Operation -> Parser Operation
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Pointer -> Operation
Rem (Pointer -> Operation) -> Parser Pointer -> Parser Operation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Pointer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"path"))
            Parser Operation -> Parser Operation -> Parser Operation
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Object -> Text -> Parser Value
op Object
v Text
"replace" Parser Value -> Parser Operation -> Parser Operation
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Pointer -> Value -> Operation
Rep (Pointer -> Value -> Operation)
-> Parser Pointer -> Parser (Value -> Operation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Pointer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"path" Parser (Value -> Operation) -> Parser Value -> Parser Operation
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"))
            Parser Operation -> Parser Operation -> Parser Operation
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Object -> Text -> Parser Value
op Object
v Text
"test"    Parser Value -> Parser Operation -> Parser Operation
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Pointer -> Value -> Operation
Tst (Pointer -> Value -> Operation)
-> Parser Pointer -> Parser (Value -> Operation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Pointer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"path" Parser (Value -> Operation) -> Parser Value -> Parser Operation
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"))
            Parser Operation -> Parser Operation -> Parser Operation
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Operation
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Expected a JSON patch operation, encountered: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BS.unpack (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
o))
        parse Value
v = String -> Value -> Parser Operation
forall a. String -> Value -> Parser a
typeMismatch String
"Operation" Value
v
        op :: Object -> Text -> Parser Value
op Object
v Text
n = Object -> Key -> Value -> Parser Value
forall b. (FromJSON b, Eq b) => Object -> Key -> b -> Parser b
fixed Object
v Key
"op" (Text -> Value
String Text
n)
        fixed :: Object -> Key -> b -> Parser b
fixed Object
o Key
n b
val = do
            b
v' <- Object
o Object -> Key -> Parser b
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
n
            if b
v' b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
val
              then b -> Parser b
forall (m :: * -> *) a. Monad m => a -> m a
return b
v'
              else Parser b
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | 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 :: (Pointer -> Pointer) -> Operation -> Operation
modifyPointer Pointer -> Pointer
f Operation
op =
  case Operation
op of
    Add{Value
Pointer
changeValue :: Value
changePointer :: Pointer
changeValue :: Operation -> Value
changePointer :: Operation -> Pointer
..} -> Operation
op{ changePointer :: Pointer
changePointer = Pointer -> Pointer
f Pointer
changePointer }
    Cpy{Pointer
fromPointer :: Pointer
changePointer :: Pointer
fromPointer :: Operation -> Pointer
changePointer :: Operation -> Pointer
..} -> Operation
op{ changePointer :: Pointer
changePointer = Pointer -> Pointer
f Pointer
changePointer, fromPointer :: Pointer
fromPointer = Pointer -> Pointer
f Pointer
fromPointer }
    Mov{Pointer
fromPointer :: Pointer
changePointer :: Pointer
fromPointer :: Operation -> Pointer
changePointer :: Operation -> Pointer
..} -> Operation
op{ changePointer :: Pointer
changePointer = Pointer -> Pointer
f Pointer
changePointer, fromPointer :: Pointer
fromPointer = Pointer -> Pointer
f Pointer
fromPointer }
    Rem{Pointer
changePointer :: Pointer
changePointer :: Operation -> Pointer
..} -> Operation
op{ changePointer :: Pointer
changePointer = Pointer -> Pointer
f Pointer
changePointer }
    Rep{Value
Pointer
changeValue :: Value
changePointer :: Pointer
changeValue :: Operation -> Value
changePointer :: Operation -> Pointer
..} -> Operation
op{ changePointer :: Pointer
changePointer = Pointer -> Pointer
f Pointer
changePointer }
    Tst{Value
Pointer
changeValue :: Value
changePointer :: Pointer
changeValue :: Operation -> Value
changePointer :: Operation -> Pointer
..} -> Operation
op{ changePointer :: Pointer
changePointer = Pointer -> Pointer
f Pointer
changePointer }

isAdd :: Operation -> Bool
isAdd :: Operation -> Bool
isAdd Add{} = Bool
True
isAdd Operation
_ = Bool
False

isCpy :: Operation -> Bool
isCpy :: Operation -> Bool
isCpy Cpy{} = Bool
True
isCpy Operation
_ = Bool
False

isMov :: Operation -> Bool
isMov :: Operation -> Bool
isMov Mov{} = Bool
True
isMov Operation
_ = Bool
False

isRem :: Operation -> Bool
isRem :: Operation -> Bool
isRem Rem{} = Bool
True
isRem Operation
_ = Bool
False

isRep :: Operation -> Bool
isRep :: Operation -> Bool
isRep Rep{} = Bool
True
isRep Operation
_ = Bool
False

isTst :: Operation -> Bool
isTst :: Operation -> Bool
isTst Tst{} = Bool
True
isTst Operation
_ = Bool
False