aeson-diff-generic (empty) → 0.0.1
raw patch · 7 files changed
+1269/−0 lines, 7 filesdep +aesondep +aeson-diffdep +basesetup-changed
Dependencies added: aeson, aeson-diff, base, bytestring, containers, dlist, hashable, mtl, scientific, tagged, template-haskell, text, th-abstraction, time, unordered-containers, uuid-types, vector
Files
- Data/Aeson/Diff/Generic.hs +58/−0
- Data/Aeson/Diff/Generic/Instances.hs +546/−0
- Data/Aeson/Diff/Generic/TH.hs +431/−0
- Data/Aeson/Diff/Generic/Types.hs +172/−0
- LICENSE +29/−0
- Setup.hs +2/−0
- aeson-diff-generic.cabal +31/−0
+ Data/Aeson/Diff/Generic.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts, MultiWayIf,+ ExistentialQuantification #-}+{-| This library allows you to apply a json-patch document+ (<https://tools.ietf.org/html/rfc6902 rfc6902>) directly to a+ haskell datatype. It's based on the "Data.Aeson.Diff" module.+-}++module Data.Aeson.Diff.Generic+ ( -- * patch operations+ Data.Aeson.Diff.Generic.patch, applyOperation, JsonPatch(..),+ getDynamic, getValueAtPointer, getDataAtPointer,+ -- * the fieldLens class+ -- | `FieldLens` provides a simpler way to create `JsonPatch` instances.+ GetSet(..), FieldLens(..)+ ) where++import Data.Aeson.Types+import Data.Aeson.Patch+import qualified Data.Aeson.Diff as Diff+import Data.Aeson.Pointer as Pointer+import Control.Monad+import qualified Data.Text as T+import Data.Aeson.Diff.Generic.Types+import Data.Aeson.Diff.Generic.Instances()++-- | Apply a json patch document to the data.+patch :: JsonPatch a => Patch -> a -> Result a+patch = foldr (>=>) pure . map applyOperation . patchOperations+{-# NOINLINE patch #-}+{-# RULES "patch/Value" patch = Diff.patch #-} ++-- | Apply a single operation to the data.+applyOperation :: JsonPatch a => Operation -> a -> Result a+applyOperation op v = case patchOp op v of+ Error msg -> Error $ opError op ++ msg+ Success ret -> Success ret+{-# INLINE [1] applyOperation #-}+{-# RULES "applyOperation/Value" applyOperation = Diff.applyOperation #-} ++opError :: Operation -> String+opError op = mconcat [+ "Operation ", opname op, " on ",+ T.unpack $ formatPointer $ changePointer op,+ " failed: " ]+ where opname (Add _ _) = "Add"+ opname (Cpy _ _) = "Copy"+ opname (Mov _ _) = "Move"+ opname (Rem _) = "Remove"+ opname (Rep _ _) = "Replace"+ opname (Tst _ _) = "Test"++patchOp :: JsonPatch a => Operation -> a -> Result a+patchOp (Add ptr val) s = addAtPointer ptr s val fromJSON+patchOp (Rem ptr) s = snd <$> deleteAtPointer ptr s (const ())+patchOp (Cpy toPath fromPath) s = copyPath fromPath toPath s+patchOp (Mov toPath fromPath) s = movePath fromPath toPath s+patchOp (Rep ptr val) s = replaceAtPointer ptr s val fromJSON+patchOp (Tst ptr val) s = testAtPointer ptr s val fromJSON
+ Data/Aeson/Diff/Generic/Instances.hs view
@@ -0,0 +1,546 @@+{-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts, MultiWayIf,+ ExistentialQuantification, TemplateHaskell, StandaloneDeriving,+ GeneralizedNewtypeDeriving#-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-| Instances are put into this module to avoid circular dependencies+ with the TH module. There is no need to import this module, since+ it is already re-exported in "Data.Aeson.Diff.Generic". This module+ is only exported for documentation purpose.+-}++module Data.Aeson.Diff.Generic.Instances+ () where++import Data.Aeson.Types+import Data.Aeson.Patch+import qualified Data.Aeson.Diff as Diff+import Data.Aeson.Pointer as Pointer+import Control.Monad+import Data.Functor.Identity+import qualified Data.Text as T+import qualified Data.Text.Lazy+import Data.Dynamic+import qualified Data.Set as Set+import qualified Data.Sequence as Seq+import qualified Data.Vector.Unboxed as UVector+import qualified Data.Vector as Vector+import qualified Data.Vector.Storable as SVector+import qualified Data.Vector.Primitive as PVector+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.HashSet as HashSet+import qualified Data.Map as Map+import Data.Word+import Data.Int+import Numeric.Natural+import Data.Version+import Foreign.C.Types+import qualified Data.IntSet+import Data.Scientific+import Data.Time.LocalTime+import Data.Time.Clock+import Data.Time.Calendar+import Data.UUID.Types+import Data.Ratio+import Data.Fixed+import Data.Semigroup hiding (Sum, Product)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.DList as DList+import Data.Hashable+import Data.Proxy+import Data.Tagged+import Unsafe.Coerce+import Data.Aeson.Diff.Generic.TH+import Data.Aeson.Diff.Generic.Types+import Data.IntMap (IntMap)+import Data.Functor.Compose+import Data.Functor.Product+import Data.Functor.Sum+import Data.Functor.Const+import Data.Functor.Classes+import Data.Tree (Tree(..))++instance FieldLens Bool+instance FieldLens Char+instance FieldLens Double+instance FieldLens Float+instance FieldLens Int+instance FieldLens Int8+instance FieldLens Int16+instance FieldLens Int32+instance FieldLens Int64+instance FieldLens Integer+instance FieldLens Natural+instance FieldLens Ordering+instance FieldLens Word+instance FieldLens Word8+instance FieldLens Word16+instance FieldLens Word32+instance FieldLens Word64+instance FieldLens ()+instance FieldLens T.Text+instance FieldLens Data.Text.Lazy.Text+instance FieldLens Version+instance FieldLens CTime+instance FieldLens Data.IntSet.IntSet+instance FieldLens Scientific+instance FieldLens LocalTime+instance FieldLens TimeOfDay+instance FieldLens UTCTime+instance FieldLens NominalDiffTime+instance FieldLens DiffTime+instance FieldLens Day+instance FieldLens UUID+instance FieldLens DotNetTime+instance (Hashable a, Eq a, FromJSON a, Typeable a, ToJSON a) =>+ FieldLens (HashSet.HashSet a)+instance (Typeable a, Integral a, ToJSON a, FromJSON a, Eq a) =>+ FieldLens (Ratio a)+instance (HasResolution a, Typeable a, FromJSON a, ToJSON a) =>+ FieldLens (Fixed a)+instance (JsonPatch a) => FieldLens (IntMap a)+instance Typeable a => FieldLens (Proxy a)++instance JsonPatch Bool+instance JsonPatch Char+instance JsonPatch Double+instance JsonPatch Float+instance JsonPatch Int+instance JsonPatch Int8+instance JsonPatch Int16+instance JsonPatch Int32+instance JsonPatch Int64+instance JsonPatch Integer+instance JsonPatch Natural+instance JsonPatch Ordering+instance JsonPatch Word+instance JsonPatch Word8+instance JsonPatch Word16+instance JsonPatch Word32+instance JsonPatch Word64+instance JsonPatch ()+instance JsonPatch T.Text+instance JsonPatch Data.Text.Lazy.Text+instance JsonPatch Version+instance JsonPatch CTime+instance JsonPatch Data.IntSet.IntSet+instance JsonPatch Scientific+instance JsonPatch LocalTime+instance JsonPatch TimeOfDay+instance JsonPatch UTCTime+instance JsonPatch NominalDiffTime+instance JsonPatch DiffTime+instance JsonPatch Day+instance JsonPatch UUID+instance JsonPatch DotNetTime+-- no indexing possible into hashset, since it is unordered.+instance (Hashable a, Eq a, FromJSON a, Typeable a, ToJSON a) =>+ JsonPatch (HashSet.HashSet a)+instance (Typeable a, Integral a, ToJSON a, FromJSON a, Eq a) =>+ JsonPatch (Ratio a)+instance (HasResolution a, Typeable a, FromJSON a, ToJSON a) =>+ JsonPatch (Fixed a)+-- IntMap is also a terminal instance, because it is represented by an+-- Array rather than an Object, which makes indexing not possible.+instance JsonPatch a => JsonPatch (IntMap a) ++deriveJsonPatch (defaultOptions {sumEncoding = ObjectWithSingleField}) ''Either+deriveJsonPatch (defaultOptions {sumEncoding = UntaggedValue}) ''Maybe+deriveJsonPatch defaultOptions ''(,)+deriveJsonPatch defaultOptions ''(,,)+deriveJsonPatch defaultOptions ''(,,,)+deriveJsonPatch defaultOptions ''(,,,,)+deriveJsonPatch defaultOptions ''(,,,,,)+deriveJsonPatch defaultOptions ''(,,,,,,)+deriveJsonPatch defaultOptions ''(,,,,,,,)+deriveJsonPatch defaultOptions ''(,,,,,,,,)+deriveJsonPatch defaultOptions ''(,,,,,,,,,)+deriveJsonPatch defaultOptions ''(,,,,,,,,,,)+deriveJsonPatch defaultOptions ''(,,,,,,,,,,,)+deriveJsonPatch defaultOptions ''(,,,,,,,,,,,,)+deriveJsonPatch defaultOptions ''(,,,,,,,,,,,,,)+deriveJsonPatch defaultOptions ''(,,,,,,,,,,,,,,)++instance Typeable a => JsonPatch (Proxy a)+deriving instance JsonPatch a => JsonPatch (Min a)+deriving instance JsonPatch a => JsonPatch (Max a)+deriving instance JsonPatch a => JsonPatch (First a)+deriving instance JsonPatch a => JsonPatch (Last a)+deriving instance JsonPatch a => JsonPatch (WrappedMonoid a)+deriving instance JsonPatch a => JsonPatch (Option a)+deriving instance JsonPatch a => JsonPatch (Identity a)+deriving instance JsonPatch a => JsonPatch (Dual a)+deriving instance (Typeable b, JsonPatch a) => JsonPatch (Const a b)+deriving instance (Eq1 f, Eq1 g, FromJSON1 f, FromJSON1 g, Typeable f,+ Typeable g, JsonPatch a, ToJSON1 f,+ ToJSON1 g, JsonPatch (f (g a)))+ => JsonPatch (Compose f g a)+deriving instance (Typeable a, JsonPatch b) => JsonPatch (Tagged a b)++intKey :: Key -> Result Int+intKey (OKey _) = Error "expected Array Key."+intKey (AKey i) = pure i++strKey :: Key -> T.Text+strKey (OKey s) = s+strKey (AKey i) = T.pack $ show i++isEndKey :: Key -> Bool+isEndKey = (== OKey "-")++-- instance FieldLens (Tree a)++splitList :: Int -> [a] -> Maybe ([a], [a])+splitList i _ | i < 0 = Nothing+splitList 0 xs = Just ([], xs)+splitList _ [] = Nothing+splitList n (x:xs) = do+ (l, r) <- splitList (n-1) xs+ pure (x:l, r)++instance (JsonPatch a) => JsonPatch (Tree a)+instance (JsonPatch a) => FieldLens (Tree a) where+ fieldLens key (Node x t) = do+ i <- intKey key+ case i of+ 0 -> pure $ GetSet x (\v -> pure $ Node v t)+ 1 -> pure $ GetSet t (\v -> pure $ Node x v)+ _ -> Error "Invalid path"++instance (ToJSON1 f, ToJSON1 g, FromJSON1 f, FromJSON1 g, Eq1 f, Eq1 g,+ JsonPatch a, Typeable f, Typeable g, JsonPatch (f a), JsonPatch (g a))+ => JsonPatch (Product f g a)+instance (ToJSON1 f, ToJSON1 g, FromJSON1 f, FromJSON1 g, Eq1 f, Eq1 g,+ JsonPatch a, Typeable f, Typeable g, JsonPatch (f a), JsonPatch (g a))+ => FieldLens (Product f g a) where+ fieldLens key (Pair l r) = do+ i <- intKey key+ case i of+ 0 -> pure $ GetSet l (\v -> pure $ Pair v r)+ 1 -> pure $ GetSet r (\v -> pure $ Pair l v)+ _ -> Error "Invalid path"++instance (ToJSON1 f, ToJSON1 g, FromJSON1 f, FromJSON1 g, Eq1 f, Eq1 g,+ JsonPatch a, Typeable f, Typeable g, JsonPatch (f a), JsonPatch (g a))+ => JsonPatch (Sum f g a)+instance (ToJSON1 f, ToJSON1 g, FromJSON1 f, FromJSON1 g, Eq1 f, Eq1 g,+ JsonPatch a, Typeable f, Typeable g, JsonPatch (f a), JsonPatch (g a))+ => FieldLens (Sum f g a) where+ fieldLens key (InL x) =+ case strKey key of+ "InL" -> pure $ GetSet x (pure . InL)+ _ -> Error "Invalid path"++ fieldLens key (InR x) =+ case strKey key of+ "InR" -> pure $ GetSet x (pure . InR)+ _ -> Error "Invalid path"++instance JsonPatch a => JsonPatch [a]+instance JsonPatch a => FieldLens [a] where+ fieldLens key lst = do+ i <- intKey key+ case splitList i lst of+ Just (l, r1:rs) ->+ pure $ GetSet r1 (\v -> pure $ l ++ v:rs)+ _ -> Error "Index out of bounds"+ {-# INLINE fieldLens #-}++ insertAt key lst v f+ | isEndKey key = (lst ++) <$> f v+ | otherwise = do+ i <- intKey key+ case splitList i lst of+ Just (l, r) -> (\v' -> l ++ v':r) <$> f v+ Nothing -> Error "Index out of bounds"+ deleteAt key lst f = do+ i <- intKey key+ case splitList i lst of+ Just (l, r1:rs) -> pure (f r1, l ++ rs)+ _ -> Error "Index out of bounds"++instance JsonPatch a => JsonPatch (NonEmpty.NonEmpty a)+instance JsonPatch a => FieldLens (NonEmpty.NonEmpty a) where+ fieldLens key ne = do+ GetSet v f <- fieldLens key (NonEmpty.toList ne)+ pure $ GetSet v (fmap NonEmpty.fromList . f)+ {-# INLINE fieldLens #-}++ insertAt key ne v f =+ NonEmpty.fromList <$> insertAt key (NonEmpty.toList ne) v f+ deleteAt key ne f = do+ (r, l) <- deleteAt key (NonEmpty.toList ne) f+ case NonEmpty.nonEmpty l of+ Nothing -> Error "Cannot delete last element of NonEmpty"+ Just ne2 -> pure (r, ne2)++instance JsonPatch a => JsonPatch (DList.DList a)+instance JsonPatch a => FieldLens (DList.DList a) where+ fieldLens key dl = do+ GetSet v f <- fieldLens key (DList.toList dl)+ pure $ GetSet v (fmap DList.fromList . f)+ {-# INLINE fieldLens #-}++ insertAt key dl v f =+ DList.fromList <$> insertAt key (DList.toList dl) v f+ deleteAt key dl f = + fmap DList.fromList <$> deleteAt key (DList.toList dl) f+ + +instance (Ord a, JsonPatch a) => JsonPatch (Set.Set a) +instance (Ord a, JsonPatch a) => FieldLens (Set.Set a) where+ fieldLens key st = do+ i <- intKey key+ when (i < 0 || i >= Set.size st) $+ Error "Index out of bounds"+ pure $ GetSet (Set.elemAt i st) $ + \v -> pure $ Set.insert v $ Set.deleteAt i st+ {-# INLINE fieldLens #-}+ + insertAt key st v f+ | isEndKey key =+ (`Set.insert` st) <$> f v+ | otherwise = do+ i <- intKey key+ when (i < 0 || i >= Set.size st) $+ Error "Index out of bounds"+ (`Set.insert` st) <$> f v++ deleteAt key st f = do+ i <- intKey key+ when (i < 0 || i >= Set.size st) $+ Error "Index out of bounds"+ pure (f $ Set.elemAt i st, Set.deleteAt i st)++instance (Ord a, JsonPatch a) => JsonPatch (Seq.Seq a) where+instance (Ord a, JsonPatch a) => FieldLens (Seq.Seq a) where+ fieldLens key sq = do+ i <- intKey key+ case Seq.lookup i sq of+ Nothing -> Error "Index out of bounds"+ Just v -> pure $ GetSet v $+ \v' -> pure $ Seq.update i v' sq+ {-# INLINE fieldLens #-}++ insertAt key sq v f+ | isEndKey key = (sq Seq.|>) <$> f v+ | otherwise = do+ i <- intKey key+ (\v'-> Seq.insertAt i v' sq) <$> f v++ deleteAt key sq f = do+ i <- intKey key+ case Seq.lookup i sq of+ Nothing -> Error "Index out of bounds"+ Just v -> pure (f v, Seq.deleteAt i sq)+ {-# INLINE deleteAt #-}++instance (JsonPatch a) => FieldLens (Vector.Vector a) where+ fieldLens key v = do+ i <- intKey key+ when (i < 0 || i >= Vector.length v) $+ Error "Index out of bounds"+ let (l, r) = Vector.splitAt i v+ pure $ GetSet (Vector.head r) $+ \v' -> pure $ l Vector.++ Vector.cons v' (Vector.tail r)+ + {-# INLINE fieldLens #-}+ + insertAt key vec v f+ | isEndKey key = Vector.snoc vec <$> f v+ | otherwise = do+ i <- intKey key+ when (i < 0 || i >= Vector.length vec) $+ Error "Index out of bounds"+ let (l, r) = Vector.splitAt i vec+ (\v' -> l Vector.++ Vector.cons v' r) <$> f v++ deleteAt key vec f = do+ i <- intKey key+ when (i < 0 || i >= Vector.length vec) $+ Error "Index out of bounds"+ let (l, r) = Vector.splitAt i vec+ pure (f $ Vector.head r, l Vector.++ Vector.tail r)++instance (UVector.Unbox a, JsonPatch a) => JsonPatch (UVector.Vector a)+instance (UVector.Unbox a, JsonPatch a) => FieldLens (UVector.Vector a) where+ fieldLens key v = do+ i <- intKey key+ when (i < 0 || i >= UVector.length v) $+ Error "Index out of bounds"+ let (l, r) = UVector.splitAt i v+ pure $ GetSet (UVector.head r) $+ \v' -> pure $ l UVector.++ UVector.cons v' (UVector.tail r)+ {-# INLINE fieldLens #-}++ insertAt key vec v f+ | isEndKey key = UVector.snoc vec <$> f v+ | otherwise = do+ i <- intKey key+ when (i < 0 || i >= UVector.length vec) $+ Error "Index out of bounds"+ let (l, r) = UVector.splitAt i vec+ (\v' -> l UVector.++ UVector.cons v' r) <$> f v++ deleteAt key vec f = do+ i <- intKey key+ when (i < 0 || i >= UVector.length vec) $+ Error "Index out of bounds"+ let (l, r) = UVector.splitAt i vec+ pure (f $ UVector.head r, l UVector.++ UVector.tail r)++instance (SVector.Storable a, JsonPatch a) => JsonPatch (SVector.Vector a) +instance (SVector.Storable a, JsonPatch a) => FieldLens (SVector.Vector a) where+ fieldLens key v = do+ i <- intKey key+ when (i < 0 || i >= SVector.length v) $+ Error "Index out of bounds"+ let (l, r) = SVector.splitAt i v+ pure $ GetSet (SVector.head r) $+ \v' -> pure $ l SVector.++ SVector.cons v' (SVector.tail r)+ {-# INLINE fieldLens #-}++ insertAt key vec v f+ | isEndKey key = SVector.snoc vec <$> f v+ | otherwise = do+ i <- intKey key+ when (i < 0 || i >= SVector.length vec) $+ Error "Index out of bounds"+ let (l, r) = SVector.splitAt i vec+ (\v' -> l SVector.++ SVector.cons v' r) <$> f v++ deleteAt key vec f = do+ i <- intKey key+ when (i < 0 || i >= SVector.length vec) $+ Error "Index out of bounds"+ let (l, r) = SVector.splitAt i vec+ pure (f $ SVector.head r, l SVector.++ SVector.tail r)++instance (PVector.Prim a, JsonPatch a) => JsonPatch (PVector.Vector a) +instance (PVector.Prim a, JsonPatch a) => FieldLens (PVector.Vector a) where+ fieldLens key v = do+ i <- intKey key+ when (i < 0 || i >= PVector.length v) $+ Error "Index out of bounds"+ let (l, r) = PVector.splitAt i v+ pure $ GetSet (PVector.head r) $+ \v' -> pure $ l PVector.++ PVector.cons v' (PVector.tail r)+ {-# INLINE fieldLens #-}++ insertAt key vec v f+ | isEndKey key = PVector.snoc vec <$> f v+ | otherwise = do+ i <- intKey key+ when (i < 0 || i >= PVector.length vec) $+ Error "Index out of bounds"+ let (l, r) = PVector.splitAt i vec+ (\v' -> l PVector.++ PVector.cons v' r) <$> f v++ deleteAt key vec f = do+ i <- intKey key+ when (i < 0 || i >= PVector.length vec) $+ Error "Index out of bounds"+ let (l, r) = PVector.splitAt i vec+ pure (f $ PVector.head r, l PVector.++ PVector.tail r)++getMapKey :: FromJSONKey a => T.Text -> Result (Maybe a)+getMapKey s = case fromJSONKey of+ FromJSONKeyCoerce _ -> pure $ Just $ unsafeCoerce s+ FromJSONKeyText fromTxt -> pure $ Just $ fromTxt s+ FromJSONKeyTextParser parser -> Just <$> parse parser s+ FromJSONKeyValue _ -> pure Nothing++getHashMapKey :: FromJSONKey a => Key -> Result a+getHashMapKey key =+ maybe (Error "Invalid path") pure =<<+ getMapKey (strKey key) ++instance (ToJSONKey k, Typeable k, Eq k, Hashable k, FromJSONKey k, JsonPatch a)+ => JsonPatch (HashMap.HashMap k a)+instance (ToJSONKey k, Typeable k, Eq k, Hashable k, FromJSONKey k, JsonPatch a)+ => FieldLens (HashMap.HashMap k a) where+ fieldLens key hm = do+ k <- getHashMapKey key+ case HashMap.lookup k hm of+ Nothing -> Error "Invalid Pointer"+ Just val ->+ pure $ GetSet val (\v -> pure $ HashMap.insert k v hm)+ {-# INLINE fieldLens #-}++ insertAt key hm v f = do+ k <- getHashMapKey key+ (\v' -> HashMap.insert k v' hm) <$> f v+ + deleteAt key hm f = do+ k <- getHashMapKey key+ case HashMap.lookup k hm of+ Nothing -> Error "Invalid Pointer"+ Just val -> pure (f val, HashMap.delete k hm)++instance (FromJSONKey k, ToJSONKey k, Eq k, Ord k, JsonPatch k, JsonPatch a)+ => JsonPatch (Map.Map k a)+instance (FromJSONKey k, ToJSONKey k, Eq k, Ord k, JsonPatch a, JsonPatch k)+ => FieldLens (Map.Map k a) where+ fieldLens key map1 = do+ k <- getMapKey $ strKey key+ case k of+ Nothing -> do+ i <- intKey key+ when (i < 0 || i >= Map.size map1) $+ Error "Invalid Pointer"+ let val = Map.elemAt i map1+ pure $ GetSet val+ (\(k2, v) -> pure $ Map.insert k2 v $ + Map.deleteAt i map1)+ Just s ->+ case Map.lookup s map1 of+ Nothing -> Error "Invalid Pointer"+ Just val ->+ pure $ GetSet val (\v -> pure $ Map.insert s v map1)+ {-# INLINE fieldLens #-}++ insertAt key map1 val f = do+ k <- getMapKey $ strKey key+ case k of+ Nothing -> do+ if isEndKey key then pure () else do+ i <- intKey key+ when (i < 0 || i >= Map.size map1) $+ Error "Invalid Pointer"+ (k2, v) <- f val+ pure $ Map.insert k2 v map1+ Just s ->+ (\v -> Map.insert s v map1) <$> f val+ + deleteAt key map1 f = do+ k <- getMapKey $ strKey key+ case k of+ Nothing -> do+ i <- intKey key+ when (i < 0 || i >= Map.size map1) $+ Error "Invalid Pointer"+ pure (f $ Map.elemAt i map1, Map.deleteAt i map1)+ Just s -> case Map.lookup s map1 of+ Nothing -> Error "Invalid Pointer"+ Just v -> pure (f v, Map.delete s map1)++instance JsonPatch Value where+ getAtPointer ptr val f =+ f <$> Pointer.get ptr val+ deleteAtPointer ptr val f =+ (,) <$> getAtPointer ptr val f <*>+ Diff.applyOperation (Rem ptr) val+ addAtPointer ptr val val2 f = do+ val3 <- f val2+ Diff.applyOperation (Add ptr val3) val+ copyPath from to =+ Diff.applyOperation (Cpy to from)+ movePath from to =+ Diff.applyOperation (Mov to from)+ replaceAtPointer ptr val val2 f = do+ val3 <- f val2+ Diff.applyOperation (Rep ptr val3) val+ testAtPointer ptr val val2 f = do+ val3 <- f val2+ Diff.applyOperation (Tst ptr val3) val+
+ Data/Aeson/Diff/Generic/TH.hs view
@@ -0,0 +1,431 @@+{-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts, MultiWayIf,+ ExistentialQuantification, TemplateHaskell, PatternGuards #-}+{-|+This module contains functions to automatically derive `JsonPatch` instances.+-}+++module Data.Aeson.Diff.Generic.TH (deriveJsonPatch)+ where++import Data.Aeson.Types+import Data.Aeson.Pointer as Pointer+import Data.Dynamic+import Language.Haskell.TH+import Language.Haskell.TH.Datatype+import Data.List+import Data.Aeson.Diff.Generic.Types+import Text.Read+import qualified Data.Text as T+import Control.Monad+import Data.Maybe+import Control.Applicative+++data GetSetPure s = forall v. JsonPatch v => GetSetPure Bool v (v -> s)+type PathLens s = s -> Path -> Result (Path, Path, GetSetPure s)++data GetSetMaybe s = forall v. JsonPatch (Maybe v) =>+ GetSetMaybe (Maybe v) (Maybe v -> s)+-- a lens which only works on record fields which have type Maybe+type PathLensMaybe s = s -> Path -> Result (GetSetMaybe s)++-- | Derive a JsonPatch instance, using the given aeson `Options`.+-- This should work with a `ToJSON` and `FromJSON` instance that uses the+-- same options.+deriveJsonPatch :: Options -> Name -> DecsQ+deriveJsonPatch options name = do+ (pathLensName, pathLensDecl) <- makePathLens options name+ (mbLensName, mbLensDecl) <- makeMaybeLens options name+ sigVars <- datatypeVars <$> reifyDatatype name+ vars <- mapM (const $ newName "a") sigVars+ let appliedType = foldl appT (conT name) $ map varT vars+ constrained =+ forallT (map plainTV vars) $ + mapM (\v -> [t| JsonPatch $(varT v) |])+ vars+ pathLensSig <- sigD pathLensName $ constrained + [t| $(appliedType) -> Path ->+ Result (Path, Path, GetSetPure $(appliedType)) |]+ mbLensSig <- sigD mbLensName $ constrained+ [t| $(appliedType) -> Path -> Result (GetSetMaybe $(appliedType)) |]+ context <- mapM (\v -> [t| JsonPatch $(varT v) |]) vars+ classDecl <- instanceD (pure context)+ [t| JsonPatch $(appliedType) |]+ [ funD 'getAtPointer [+ clause [] (normalB [| getAtPointerTH $(varE pathLensName) |]) []]+ , funD 'deleteAtPointer [+ clause [] (normalB [| deleteAtPointerTH $(varE pathLensName)+ $(varE mbLensName) |]) []]+ , funD 'addAtPointer [+ clause [] (normalB [| addAtPointerTH $(varE pathLensName) |]) []]+ , funD 'movePath [+ clause [] (normalB [| movePathTH $(varE pathLensName) |]) []]+ , funD 'copyPath [+ clause [] (normalB [| copyPathTH $(varE pathLensName) |]) []]+ , funD 'replaceAtPointer [+ clause [] (normalB [| replaceAtPointerTH $(varE pathLensName) |]) []]+ , funD 'testAtPointer [+ clause [] (normalB [| testAtPointerTH $(varE pathLensName) |]) []]+ ]+ pure [pathLensSig, pathLensDecl, mbLensSig, mbLensDecl, classDecl]+++getAtPointerTH :: (JsonPatch s) => PathLens s -> Pointer -> s+ -> (forall v.JsonPatch v => v -> r) -> Result r+getAtPointerTH _ (Pointer []) s f = pure $ f s+getAtPointerTH l (Pointer path) s f = do+ (_, subPath, GetSetPure _ subS _) <- l s path+ getAtPointer (Pointer subPath) subS f++movePathTH :: (JsonPatch s) => PathLens s -> Pointer -> Pointer -> s+ -> Result s+movePathTH _ (Pointer []) (Pointer []) s = pure s+movePathTH _ (Pointer []) (Pointer _) _ =+ Error "Cannot move to subpath"+movePathTH l (Pointer fromPath) (Pointer toPath) s = do+ (pref, toSubPath, GetSetPure _ x setr) <- l s toPath+ if pref `isPrefixOf` toPath+ then setr <$> movePath (Pointer (take (length pref) fromPath))+ (Pointer toSubPath) x+ else do (v, s') <- deleteAtPointer (Pointer fromPath) s toDyn+ addAtPointer (Pointer toPath) s' v getDynamic++copyPathTH :: (JsonPatch s) => PathLens s -> Pointer -> Pointer -> s+ -> Result s+copyPathTH _ (Pointer []) (Pointer []) s = pure s+copyPathTH l (Pointer fromPath) (Pointer toPath) s = do+ v <- getAtPointerTH l (Pointer fromPath) s toDyn+ addAtPointer (Pointer toPath) s v getDynamic++replaceAtPointerTH :: (JsonPatch s) => PathLens s -> Pointer -> s -> r ->+ (forall v.JsonPatch v => r -> Result v) -> Result s+replaceAtPointerTH _ (Pointer []) _ v f = f v+replaceAtPointerTH l (Pointer path) s val f = do+ (_, subPath, GetSetPure _ x setr) <- l s path+ setr <$> replaceAtPointer (Pointer subPath) x val f++addAtPointerTH :: (JsonPatch s) => PathLens s -> Pointer -> s -> r ->+ (forall v.JsonPatch v => r -> Result v) -> Result s+addAtPointerTH _ (Pointer []) _ v f = f v +addAtPointerTH l (Pointer path) s val f = do+ (_, subPath, GetSetPure isRecord x setr) <- l s path+ if null subPath && not isRecord+ then Error "Cannot add value to non record field"+ else setr <$> addAtPointer (Pointer subPath) x val f++deleteAtPointerTH :: JsonPatch s => PathLens s -> PathLensMaybe s+ -> Pointer -> s -> (forall v.JsonPatch v => v -> r)+ -> Result (r, s)+deleteAtPointerTH _ _ (Pointer []) _ _ =+ Error "Invalid path"+deleteAtPointerTH l1 l2 (Pointer path) s f =+ (do GetSetMaybe v setr <- l2 s path+ if isNothing v+ then Error "fallthrough"+ else pure (f v, setr Nothing)) <|>+ (do (_, subPath, GetSetPure _ x setr) <- l1 s path+ fmap setr <$> deleteAtPointer (Pointer subPath) x f)+ +testAtPointerTH :: (JsonPatch s) => PathLens s -> Pointer -> s -> r ->+ (forall v.JsonPatch v => r -> Result v) -> Result s+testAtPointerTH _ (Pointer []) s r f = do+ v <- f r+ if v == s then pure s+ else Error "Test failed"+testAtPointerTH l (Pointer path) s val f = do+ (_, subPath, GetSetPure _ x _) <- l s path+ _ <- testAtPointer (Pointer subPath) x val f+ pure s++-- match against the key and the rest of the list+matchKey :: Key -> PatQ -> ExpQ -> MatchQ+matchKey (OKey str) rest e = do+ strVar <- newName "str"+ match (conP 'OKey [varP strVar] `consP` rest)+ (guardedB [liftA2 (,)+ (normalG [| $(varE strVar) ==+ T.pack $(litE $ stringL $ T.unpack str)+ |])+ e])+ []++matchKey (AKey i) rest e =+ match (conP 'AKey [litP $ integerL $ fromIntegral i] `consP` rest)+ (normalB e) []++keyExp :: Key -> ExpQ+keyExp (OKey str) = [| OKey $ T.pack $(litE $ stringL $ T.unpack str) |]+keyExp (AKey i) = [| AKey i |]+ +makeKey :: String -> Key+makeKey str = case readMaybe str of+ Nothing -> OKey $ T.pack str+ Just i -> AKey i++consP :: PatQ -> PatQ -> PatQ+consP x y = conP '(:) [x, y]++select :: [a] -> [([a], a, [a])]+select [] = []+select l@(_:lt) = zip3 (inits l) l (tails lt)++appListE :: ExpQ -> [ExpQ] -> ExpQ+appListE = foldl appE++invalidMatch :: MatchQ+invalidMatch = match wildP (normalB [| Error "Invalid path" |]) []++-- create matches for positional fields+makePosCases :: Name -> Maybe Key -> Name -> Int -> MatchQ+makePosCases pathVar prefix consName nFields = do+ vs <- replicateM nFields $ newName "var"+ v2 <- newName "var"+ subPath <- newName "path"+ let mkPosMatch :: ([Name], Name, [Name]) -> Integer -> MatchQ+ mkPosMatch (p, v, n) i =+ matchKey (AKey $ fromIntegral i) (varP subPath)+ [| pure ( $(listE $ maybeToList (keyExp <$> prefix) ++ [+ appE (conE 'AKey) (litE $ IntegerL i)])+ , $(varE subPath)+ , GetSetPure False $(varE v)+ $(lamE [varP v2] $+ appListE (conE consName) $+ varE <$> (p ++ v2 : n))+ )+ |]+ casePrefix f = case prefix of+ Nothing -> f pathVar + Just key -> do+ subPathVar <- newName "subPath"+ caseE (varE pathVar)+ [matchKey key (varP subPathVar) (f subPathVar), invalidMatch]++ match (conP consName $ map varP vs)+ (normalB $ casePrefix $ \subPathVar ->+ caseE (varE subPathVar) $+ zipWith mkPosMatch (select vs) [0..] ++ [invalidMatch] )+ []++-- create matches for record fields+makeRecCases :: Name -> Maybe Key -> [String] -> Name -> MatchQ+makeRecCases pathVar prefix recordFields consName = do+ vs <- mapM (const $ newName "var") recordFields+ v2 <- newName "var"+ subPath <- newName "path"+ let mkRecMatch :: ([Name], Name, [Name]) -> String -> MatchQ+ mkRecMatch (p, v, n) fieldName =+ matchKey (makeKey fieldName) (varP subPath)+ [| pure ( $(listE $ maybeToList (keyExp <$> prefix) +++ [keyExp $ makeKey fieldName])+ , $(varE subPath)+ , GetSetPure True $(varE v)+ $(lamE [varP v2] $+ appListE (conE consName) $+ varE <$> (p ++ v2 : n))+ )+ |]+ casePrefix f = case prefix of+ Nothing -> f pathVar + Just key -> do+ subPathVar <- newName "subPath"+ caseE (varE pathVar)+ [matchKey key (varP subPathVar) (f subPathVar), invalidMatch]++ match (conP consName $ map varP vs)+ (normalB $ casePrefix $ \subPathVar ->+ caseE (varE subPathVar) $+ zipWith mkRecMatch (select vs) recordFields ++ [invalidMatch])+ []++isMaybe :: Type -> Bool+isMaybe (AppT (ConT name) _) = name == ''Maybe +isMaybe _ = False++getMaybeVars :: [Type] -> [Name] -> [([Name], Name, [Name])]+getMaybeVars types vars =+ map snd $ filter (isMaybe . fst) $+ zip types $ select vars++makePathLensName :: String -> String -> String+makePathLensName prefix ('(':r)+ | (n, ")") <- span (== ',') r = + prefix ++ "Tuple" ++ show (length n)+makePathLensName prefix s = prefix ++ s+ +-- create matches for record fields+makeMaybeRecCases :: Name -> Maybe Key -> [String] -> [Type] -> Name -> Maybe MatchQ+makeMaybeRecCases _ _ _ types _+ | not $ any isMaybe types = Nothing+makeMaybeRecCases pathVar prefix recordFields types consName = Just $ do+ vs <- mapM (const $ newName "var") recordFields+ v2 <- newName "var"+ let mkRecMatch :: ([Name], Name, [Name]) -> String -> MatchQ+ mkRecMatch (p, v, n) fieldName =+ matchKey (makeKey fieldName) (listP [])+ [| pure ( GetSetMaybe $(varE v)+ $(lamE [varP v2] $+ appListE (conE consName) $+ varE <$> (p ++ v2 : n))+ ) |]+ casePrefix f = case prefix of+ Nothing -> f pathVar + Just key -> do+ subPathVar <- newName "subPath"+ caseE (varE pathVar)+ [matchKey key (varP subPathVar) (f subPathVar), invalidMatch]++ match (conP consName $ map varP vs)+ (normalB $ casePrefix $ \subPathVar ->+ caseE (varE subPathVar) $+ zipWith mkRecMatch (getMaybeVars types vs) recordFields ++ [invalidMatch])+ []++-- create a match for a single positional field+makeSingleCase :: Name -> Maybe Key -> Name -> MatchQ+makeSingleCase pathVar prefix consName = do+ v <- newName "var"+ v2 <- newName "var"+ subPath <- newName "path"+ match (conP consName [varP v])+ (normalB $ case prefix of+ Nothing ->+ [| pure ( $(listE [])+ , $(varE pathVar)+ , GetSetPure False $(varE v)+ $(lamE [varP v2] $+ appE (conE consName) $+ varE v2)) |]+ Just key ->+ caseE (varE pathVar) [+ matchKey key (varP subPath)+ [| pure ( $(listE [keyExp key])+ , $(varE subPath)+ , GetSetPure False $(varE v)+ $(lamE [varP v2] $+ appE (conE consName) $+ varE v2)) |]+ , invalidMatch]+ ) []++makePathLens :: Options -> Name -> Q (Name, Dec)+makePathLens options name = do+ typeInfo <- reifyDatatype name+ let funName = mkName $ makePathLensName "generatedPathLensFor" $+ nameBase name+ struc <- newName "struc"+ pathVar <- newName "path"+ let nConstructors = length $ datatypeCons typeInfo+ isTaggedObject = case sumEncoding options of+ TaggedObject _ _ -> True+ _ -> False++ makeCase :: ConstructorInfo -> Maybe MatchQ+ makeCase consInfo =+ let prefix+ | (nConstructors == 1) &&+ not (tagSingleConstructors options) = Nothing+ | otherwise = case sumEncoding options of+ UntaggedValue -> Nothing+ TaggedObject _ contentsName ->+ Just $ makeKey contentsName+ TwoElemArray -> Just $ AKey 1+ ObjectWithSingleField ->+ Just $ makeKey $ constructorTagModifier options $+ nameBase $ constructorName consInfo+ in case constructorVariant consInfo of+ RecordConstructor [] -> Nothing+ RecordConstructor [_]+ | unwrapUnaryRecords options &&+ -- unwrapping is not done for taggedObject with multiple+ -- constructors+ (nConstructors == 1 || not isTaggedObject) ->+ Just $ makeSingleCase pathVar prefix $+ constructorName consInfo+ RecordConstructor fieldNames ->+ Just $ makeRecCases pathVar+ -- fields are unpacked into the object with TaggedObject+ (if isTaggedObject then Nothing else prefix)+ (map (fieldLabelModifier options . nameBase) fieldNames) $+ constructorName consInfo+ _ -> case length $ constructorFields consInfo of+ 0 -> Nothing+ 1 -> Just $ makeSingleCase pathVar prefix $+ constructorName consInfo+ n -> Just $ makePosCases pathVar prefix+ (constructorName consInfo) n++ cases :: [MatchQ]+ cases = mapMaybe makeCase (datatypeCons typeInfo)++ lensClause = case cases of+ [] -> clause [wildP, wildP] (normalB [| Error "Invalid Path" |]) []+ _ -> clause [varP struc, varP pathVar] (+ normalB $+ caseE (varE struc) $+ cases ++ if length cases == nConstructors+ then [] else [invalidMatch]+ ) []++ lensDecl <- funD funName [lensClause]+ pure (funName, lensDecl)++-- return a lens that only works on maybe fields. Ugh, so much duplication...+makeMaybeLens :: Options -> Name -> Q (Name, Dec)+makeMaybeLens options name = do+ typeInfo <- reifyDatatype name+ let funName = mkName $ makePathLensName "generatedMaybePathLensFor" $+ nameBase name+ struc <- newName "struc"+ pathVar <- newName "path"+ let nConstructors = length $ datatypeCons typeInfo+ isTaggedObject = case sumEncoding options of+ TaggedObject _ _ -> True+ _ -> False++ makeCase :: ConstructorInfo -> Maybe MatchQ+ makeCase consInfo =+ let prefix+ | (nConstructors == 1) &&+ not (tagSingleConstructors options) = Nothing+ | otherwise = case sumEncoding options of+ UntaggedValue -> Nothing+ TaggedObject _ contentsName ->+ Just $ makeKey contentsName+ TwoElemArray -> Just $ AKey 1+ ObjectWithSingleField ->+ Just $ makeKey $ constructorTagModifier options $+ nameBase $ constructorName consInfo+ in case constructorVariant consInfo of+ RecordConstructor [] -> Nothing+ RecordConstructor [_]+ | unwrapUnaryRecords options &&+ -- unwrapping is not done for taggedObject with multiple+ -- constructors+ (nConstructors == 1 || not isTaggedObject) ->+ Nothing+ RecordConstructor fieldNames ->+ if omitNothingFields options then + makeMaybeRecCases pathVar+ -- fields are unpacked into the object with TaggedObject+ (if isTaggedObject then Nothing else prefix)+ (map (fieldLabelModifier options . nameBase) fieldNames)+ (constructorFields consInfo)+ (constructorName consInfo)+ else Nothing+ _ -> Nothing++ cases :: [MatchQ]+ cases = mapMaybe makeCase (datatypeCons typeInfo)++ lensClause = case cases of+ [] -> clause [wildP, wildP] (normalB [| Error "Invalid Path" |]) []+ _ -> clause [varP struc, varP pathVar] (+ normalB $+ caseE (varE struc) $+ cases ++ if length cases == nConstructors+ then [] else [invalidMatch]+ ) []+ + lensDecl <- funD funName [lensClause]+ pure (funName, lensDecl)
+ Data/Aeson/Diff/Generic/Types.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts, DefaultSignatures,+ MultiWayIf, ExistentialQuantification, TemplateHaskell #-}+module Data.Aeson.Diff.Generic.Types where++import Data.Aeson.Types+import Data.Aeson.Pointer as Pointer+import Control.Monad+import Data.Dynamic++-- | An existentially quantified getter and setter. The data inside+-- is manipulated using json conversion functions (`toJSON`,+-- `fromJSON`), or "Data.Dynamic" (`getDynamic`, `toDyn`, etc...).+data GetSet s = forall v. JsonPatch v => GetSet v (v -> Result s)++class (Eq s, ToJSON s, FromJSON s, Typeable s) => FieldLens s where+ -- | Map a key to a getter and setter on the given data.+ fieldLens :: Key -> s -> Result (GetSet s)+ fieldLens _ _ = Error "Invalid pointer"++ -- | Delete and return the data at the given key. The helper+ -- function determines which value to return: `toJSON` to return an+ -- aeson `Value`, `toDyn` to return a `Dynamic`.+ deleteAt :: Key -> s -> (forall v.(JsonPatch v) => v -> r)+ -> Result (r, s)+ deleteAt _ _ _ = Error "Illegal operation"++ -- | Insert a value at the given key. The helper function+ -- determines how to convert the value: `fromJSON` to convert from+ -- an aeson `Value`, `getDynamic` to convert from a `Dynamic`.+ insertAt :: Key -> s -> r -> (forall v.(JsonPatch v) => r -> Result v)+ -> Result s+ insertAt _ _ _ _ = Error "Illegal operation"++-- | This class defines all operations necessary for applying patches.+-- Instances can be written by hand, however it's easier to use the+-- `fieldLens` class instead, or to derive it automatically using the+-- template haskell functions from the "Data.Aeson.Diff.Generic.TH"+-- module. The default implementation is based on `fieldLens`, which+-- matches a string to a existentially quantified getter and setter+-- (the `GetSet` datatype). The Instances can be found in the+-- "Data.Aeson.Diff.Generic.Instances" module, which this module+-- exports.+class (Eq s, ToJSON s, FromJSON s, Typeable s) => JsonPatch s where+ -- | Retrieve the value at the pointer. To get back a json `Value`+ -- use `toJSON` as the helper function, to get back a `Dynamic` use+ -- `toDyn`.+ getAtPointer :: Pointer -> s -> (forall v.JsonPatch v => v -> r) -> Result r+ default getAtPointer :: FieldLens s => Pointer -> s+ -> (forall v.JsonPatch v => v -> r) -> Result r+ getAtPointer (Pointer []) s f = pure $ f s+ getAtPointer (Pointer (key:path)) s f = do+ GetSet s2 _ <- fieldLens key s+ getAtPointer (Pointer path) s2 f++ -- | Remove the value at pointer from the data. The original+ -- value is returned. To get back a json `Value` use `toJSON` as+ -- the helper function, to get back a `Dynamic` use `toDyn`.+ deleteAtPointer :: Pointer -> s -> (forall v.JsonPatch v => v -> r)+ -> Result (r, s)+ default deleteAtPointer :: FieldLens s => Pointer -> s+ -> (forall v.JsonPatch v => v -> r) -> Result (r, s)+ deleteAtPointer (Pointer []) _ _ = Error "Invalid pointer"+ deleteAtPointer (Pointer [key]) s f = deleteAt key s f+ deleteAtPointer (Pointer (key:path)) s f = do+ GetSet v setr <- fieldLens key s+ join $ traverse setr <$> deleteAtPointer (Pointer path) v f++ -- | Add a value at the pointer. To insert a json `Value`, use+ -- `fromJSON` as the helper function, to insert a `Dynamic` use `getDynamic`.+ addAtPointer :: Pointer -> s -> r ->+ (forall v.JsonPatch v => r -> Result v) -> Result s+ default addAtPointer :: FieldLens s => Pointer -> s -> r+ -> (forall v.JsonPatch v => r -> Result v) -> Result s+ addAtPointer (Pointer []) _ v f = f v+ addAtPointer (Pointer [key]) s val f =+ insertAt key s val f+ addAtPointer (Pointer (key:path)) s val f =+ updateAtKey key s $ \v ->+ addAtPointer (Pointer path) v val f++ -- | copyPath @src@ @dst@ s. Copy the value at src to dest in s.+ -- If the types don't match an error is returned+ copyPath :: Pointer -> Pointer -> s -> Result s+ default copyPath :: FieldLens s => Pointer -> Pointer -> s -> Result s+ copyPath (Pointer (fromKey: fromPath)) (Pointer (toKey: toPath)) s+ | fromKey == toKey =+ updateAtKey toKey s $+ copyPath (Pointer fromPath) (Pointer toPath)+ copyPath from to_ s = do+ v <- getAtPointer from s toDyn+ addAtPointer to_ s v getDynamic++ -- | movePath @src@ @dst@ s. Move the value from src to dest in+ -- s. If the types don't match an error is returned+ movePath :: Pointer -> Pointer -> s -> Result s+ default movePath :: FieldLens s => Pointer -> Pointer -> s -> Result s+ movePath (Pointer []) (Pointer []) s = pure s+ movePath (Pointer []) _ _ = Error "cannot move to child"+ movePath (Pointer (fromKey: fromPath)) (Pointer (toKey: toPath)) s+ | fromKey == toKey =+ updateAtKey toKey s $+ movePath (Pointer fromPath) (Pointer toPath)+ movePath from to_ s = do+ (v, s') <- deleteAtPointer from s toDyn+ addAtPointer to_ s' v getDynamic++ -- | Replace the value at the pointer with the new value. To replace+ -- using a json `Value`, use `fromJSON` as the helper function, to+ -- insert a `Dynamic` use `getDynamic`.+ replaceAtPointer :: Pointer -> s -> r ->+ (forall v.JsonPatch v => r -> Result v) -> Result s+ default replaceAtPointer :: FieldLens s => Pointer -> s -> r+ -> (forall v.JsonPatch v => r -> Result v)+ -> Result s+ replaceAtPointer (Pointer []) _ v f = f v+ replaceAtPointer (Pointer [key]) s val f =+ setAtKey key s val f+ replaceAtPointer (Pointer (key:path)) s val f =+ updateAtKey key s (\v -> replaceAtPointer (Pointer path) v val f)+ {-# INLINABLE replaceAtPointer #-} ++ -- | Test if the value at the pointer matches the given value (after+ -- conversion). Return the data if they match, give an error+ -- otherwise.+ testAtPointer :: Pointer -> s -> r ->+ (forall v.JsonPatch v => r -> Result v) -> Result s+ default testAtPointer :: FieldLens s => Pointer -> s -> r+ -> (forall v.JsonPatch v => r -> Result v) -> Result s+ testAtPointer (Pointer []) s r f = do+ v <- f r+ if v == s then pure s+ else Error "Test failed"+ testAtPointer (Pointer (key:path)) s val f = do+ _ <- updateAtKey key s $ \v ->+ testAtPointer (Pointer path) v val f+ pure s+ {-# INLINABLE testAtPointer #-} ++-- | Get the json value at the pointer. Gives an error if the+-- destination doesn't exist.+getValueAtPointer :: JsonPatch s => Pointer -> s -> Result Value+getValueAtPointer p s = getAtPointer p s toJSON+{-# INLINE [1] getValueAtPointer #-}+{-# RULES "getValueAtPointer/Value" getValueAtPointer = Pointer.get #-} ++-- | Get the value at the pointer. Gives and error If the types don't+-- match or if the destination doesn't exist.+getDataAtPointer :: (JsonPatch s, Typeable a) => Pointer -> s+ -> Result a+getDataAtPointer p s = getDynamic =<< getAtPointer p s toDyn+{-# INLINE [1] getDataAtPointer #-} +{-# RULES "getDataAtPointer/Value" getDataAtPointer = Pointer.get #-} ++-- | Read a `Dynamic` value into the `Result` Monad. Gives a type error if+-- the results don't match.+getDynamic ::(Typeable a) => Dynamic -> Result a+getDynamic = maybe (Error "Couldn't match types") pure . fromDynamic++updateAtKey :: FieldLens s => Key -> s+ -> (forall v.JsonPatch v => v -> Result v)+ -> Result s+updateAtKey key s f = do+ GetSet v setr <- fieldLens key s+ setr =<< f v+{-# INLINE updateAtKey #-}++setAtKey :: FieldLens s => Key -> s -> r+ -> (forall v.JsonPatch v => r -> Result v)+ -> Result s+setAtKey k s a f = updateAtKey k s $ const (f a)+{-# INLINE setAtKey #-}+
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2018, Kristof Bastiaensen+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aeson-diff-generic.cabal view
@@ -0,0 +1,31 @@+Name: aeson-diff-generic+Version: 0.0.1+Synopsis: Apply a json-patch to any haskell datatype.+Category: Graphics, Geometry, Typography+Copyright: Kristof Bastiaensen (2018)+Stability: Unstable+License: BSD3+License-file: LICENSE+Author: Kristof Bastiaensen+Maintainer: Kristof Bastiaensen+Bug-Reports: https://github.com/kuribas/cubicbezier/issues+Build-type: Simple+Cabal-version: >=1.8+Description: Apply a json-patch to any haskell datatype. It extends the capabilities of the aeson-diff packages, and includes template haskell functions for automatically deriving the right instances.+ +Source-repository head+ type: git+ location: https://github.com/kuribas/aeson-diff-generic++Library+ Ghc-options: -Wall+ Build-depends: base >= 4.8 && <= 5, aeson, aeson-diff, bytestring (>=0.10),+ hashable, mtl, scientific, text, unordered-containers, containers,+ vector, bytestring, time, uuid-types, dlist, tagged, template-haskell,+ th-abstraction+ Exposed-Modules: Data.Aeson.Diff.Generic+ Data.Aeson.Diff.Generic.TH+ Data.Aeson.Diff.Generic.Instances+ Other-Modules: Data.Aeson.Diff.Generic.Types+ +