{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
module Data.Aeson.Diff.Generic.PathOptics
(
PathLens, PathTraversal,
overPath, replacePath, getPath, appendPath,
insertPath, deletePath, testPath,
KeyIndexed(..), Insertable(..), Appendable(..),
withPath, withoutPath,
ixP, traverseP, _1P, _2P, _3P, _4P, _5P,
_6P, _7P, _8P, _9P, _10P, _11P, _12P, _13P,
_14P, _15P, _16P, _17P, _18P, _19P, _LeftP, _RightP,
_JustP)
where
import Prelude()
import Prelude.Compat
import Data.Aeson
import Data.Aeson.Diff
import Data.Aeson.Pointer
import Data.Monoid
import Data.Functor.Compose
import Control.Lens
type PathTraversal s a = Traversal' (Path, s) (Path, a)
type PathLens s a = Lens' (Path, s) (Path, a)
class KeyIndexed s where
toKey :: Index s -> s -> Key
class KeyIndexed a => Insertable a where
insertKey :: Index a -> (IxValue a) -> a -> a
deleteKey :: Index a -> a -> Maybe (IxValue a, a)
class KeyIndexed a => Appendable a where
append :: (IxValue a) -> a -> a
withPath :: Functor f
=> Path
-> ((a -> Compose f ((,) Path) a) -> (s -> Compose f ((,) Path) s))
-> (((Path, a) -> f (Path, a)) -> (Path, s) -> f (Path, s))
withPath p2 orig f (p, v) =
fmap (over _1 (p <>)) $ getCompose $
orig (\a -> Compose $ f (p2,a)) v
withoutPath :: Functor f
=> (((Path, a) -> f (Path, a)) -> ((Path, s) -> f (Path, s)))
-> ((a -> f a) -> (s -> f s))
withoutPath l f v = snd <$> l (traverseOf _2 f) (rootPath, v)
rootPath :: Path
rootPath = []
overPath :: ToJSON a => PathTraversal s a -> (a -> a) -> s -> (Patch, s)
overPath lns f s =
snd <$>
lns (\(p2, a) ->
let a2 = f a in
( Patch [Rep (Pointer p2) (toJSON a2)]
, (p2, a2)))
(rootPath, s)
replacePath :: ToJSON a => PathTraversal s a -> a -> s -> (Patch, s)
replacePath lns = overPath lns . const
getPath :: PathTraversal s a -> s -> [(Pointer, a)]
getPath lns v = over _1 Pointer <$> (rootPath, v) ^.. lns
appendPath :: (ToJSON (IxValue a), Appendable a)
=> IxValue a -> PathTraversal s a -> s -> (Patch, s)
appendPath v lns s =
snd <$>
lns (\(p2, a) ->
let a2 = append v a
in ( Patch [Add (Pointer $ p2 ++ [OKey "-"]) (toJSON v)]
, (p2, a2)))
(rootPath, s)
insertPath :: (ToJSON (IxValue a), Insertable a)
=> Index a -> IxValue a -> PathTraversal s a -> s
-> (Patch, s)
insertPath key v lns s =
fmap snd $
lns (\(p2, a) ->
let a2 = insertKey key v a
in ( Patch [Add (Pointer $ p2 <>
[toKey key a]) (toJSON v)]
, (p2, a2)))
(rootPath, s)
deletePath :: (ToJSON (IxValue a), Insertable a)
=> Index a -> PathTraversal s a -> s
-> (Patch, s)
deletePath key lns s =
fmap snd $
lns (\(p2, a) ->
case deleteKey key a of
Nothing -> (Patch [], (p2, a))
Just (_, a2) ->
( Patch [Rem (Pointer $ p2 <> [toKey key a])]
, (p2, a2)))
(rootPath, s)
testPath :: ToJSON a => PathTraversal s a -> s -> (Patch, s)
testPath lns s =
( Patch $ (\(ptr, v) -> Tst ptr (toJSON v)) <$> getPath lns s
, s)
ixP :: (KeyIndexed s, Ixed s) =>
Index s -> Traversal' (Path, s) (Path, IxValue s)
ixP i f s = (withPath [toKey i (snd s)] (ix i)) f s
traverseP :: (a ~ Index (s a), TraversableWithIndex a s,
KeyIndexed (s a))
=> Traversal' (Path, (s a)) (Path, a)
traverseP f (p, s) =
fmap (over _1 (p <>)) $ getCompose $
itraverse (\i a -> Compose (f ([toKey i s], a))) s
_1P :: Field1 s s a a => PathLens s a
_1P = withPath [AKey 0] _1
_2P :: Field2 s s a a => PathLens s a
_2P = withPath [AKey 1] _2
_3P :: Field3 s s a a => PathLens s a
_3P = withPath [AKey 2] _3
_4P :: Field4 s s a a => PathLens s a
_4P = withPath [AKey 3] _4
_5P :: Field5 s s a a => PathLens s a
_5P = withPath [AKey 4] _5
_6P :: Field6 s s a a => PathLens s a
_6P = withPath [AKey 5] _6
_7P :: Field7 s s a a => PathLens s a
_7P = withPath [AKey 6] _7
_8P :: Field8 s s a a => PathLens s a
_8P = withPath [AKey 7] _8
_9P :: Field9 s s a a => PathLens s a
_9P = withPath [AKey 8] _9
_10P :: Field10 s s a a => PathLens s a
_10P = withPath [AKey 9] _10
_11P :: Field11 s s a a => PathLens s a
_11P = withPath [AKey 10] _11
_12P :: Field12 s s a a => PathLens s a
_12P = withPath [AKey 11] _12
_13P :: Field13 s s a a => PathLens s a
_13P = withPath [AKey 12] _13
_14P :: Field14 s s a a => PathLens s a
_14P = withPath [AKey 13] _14
_15P :: Field15 s s a a => PathLens s a
_15P = withPath [AKey 14] _15
_16P :: Field16 s s a a => PathLens s a
_16P = withPath [AKey 15] _16
_17P :: Field17 s s a a => PathLens s a
_17P = withPath [AKey 16] _17
_18P :: Field18 s s a a => PathLens s a
_18P = withPath [AKey 17] _18
_19P :: Field19 s s a a => PathLens s a
_19P = withPath [AKey 18] _19
_LeftP :: Traversal' (Path, Either a b) (Path, a)
_LeftP = withPath [OKey "Left"] _Left
_RightP :: Traversal' (Path, Either a b) (Path, b)
_RightP = withPath [OKey "Right"] _Right
_JustP :: Traversal' (Path, Maybe a) (Path, a)
_JustP = withPath [] _Just