-- |
--
-- Module      : Data.JSON.Pointer
-- Copyright   : (c) 2025 Patrick Brisbin
-- License     : AGPL-3
-- Maintainer  : pbrisbin@gmail.com
-- Stability   : experimental
-- Portability : POSIX
--
-- <https://datatracker.ietf.org/doc/html/rfc6901/>
module Data.JSON.Pointer
  ( Pointer (..)
  , pointerFromText
  , pointerToText
  , pointerToString
  , pointerL
  , atPointerL
  , splitPointer
  ) where

import Data.JSON.Patch.Prelude

import Data.Aeson (FromJSON (..), Value, withText)
import Data.Aeson.Optics (_JSON)
import Data.JSON.Pointer.Token
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Optics.Core

newtype Pointer = Pointer
  { Pointer -> [Token]
tokens :: [Token]
  }
  deriving stock (Pointer -> Pointer -> Bool
(Pointer -> Pointer -> Bool)
-> (Pointer -> Pointer -> Bool) -> Eq Pointer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pointer -> Pointer -> Bool
== :: Pointer -> Pointer -> Bool
$c/= :: Pointer -> Pointer -> Bool
/= :: Pointer -> Pointer -> Bool
Eq, Int -> Pointer -> ShowS
[Pointer] -> ShowS
Pointer -> String
(Int -> Pointer -> ShowS)
-> (Pointer -> String) -> ([Pointer] -> ShowS) -> Show Pointer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pointer -> ShowS
showsPrec :: Int -> Pointer -> ShowS
$cshow :: Pointer -> String
show :: Pointer -> String
$cshowList :: [Pointer] -> ShowS
showList :: [Pointer] -> ShowS
Show)

instance FromJSON Pointer where
  parseJSON :: Value -> Parser Pointer
parseJSON = String -> (Text -> Parser Pointer) -> Value -> Parser Pointer
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Pointer" ((Text -> Parser Pointer) -> Value -> Parser Pointer)
-> (Text -> Parser Pointer) -> Value -> Parser Pointer
forall a b. (a -> b) -> a -> b
$ (String -> Parser Pointer)
-> (Pointer -> Parser Pointer)
-> Either String Pointer
-> Parser Pointer
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser Pointer
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Pointer -> Parser Pointer
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Pointer -> Parser Pointer)
-> (Text -> Either String Pointer) -> Text -> Parser Pointer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Pointer
pointerFromText

pointerFromText :: Text -> Either String Pointer
pointerFromText :: Text -> Either String Pointer
pointerFromText Text
t = do
  [Text]
ts <- case Text -> Maybe (Char, Text)
T.uncons Text
t of
    Maybe (Char, Text)
Nothing -> [Text] -> Either String [Text]
forall a b. b -> Either a b
Right []
    Just (Char
'/', Text
rest) -> [Text] -> Either String [Text]
forall a b. b -> Either a b
Right ([Text] -> Either String [Text]) -> [Text] -> Either String [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
rest
    Maybe (Char, Text)
_ -> String -> Either String [Text]
forall a b. a -> Either a b
Left String
"A non-empty pointer must begin with /"
  [Token] -> Pointer
Pointer ([Token] -> Pointer)
-> Either String [Token] -> Either String Pointer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Either String Token) -> [Text] -> Either String [Token]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Text -> Either String Token
tokenFromText [Text]
ts

pointerToText :: Pointer -> Text
pointerToText :: Pointer -> Text
pointerToText = (Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Pointer -> Text) -> Pointer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> (Pointer -> [Text]) -> Pointer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> Text) -> [Token] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Token -> Text
tokenToText ([Token] -> [Text]) -> (Pointer -> [Token]) -> Pointer -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.tokens)

pointerToString :: Pointer -> String
pointerToString :: Pointer -> String
pointerToString = Text -> String
unpack (Text -> String) -> (Pointer -> Text) -> Pointer -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pointer -> Text
pointerToText

-- | Access a 'Pointer' like 'ix', used for indexing
pointerL :: Pointer -> AffineTraversal' Value Value
pointerL :: Pointer -> AffineTraversal' Value Value
pointerL = (Token
 -> AffineTraversal' Value Value -> AffineTraversal' Value Value)
-> AffineTraversal' Value Value
-> [Token]
-> AffineTraversal' Value Value
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (AffineTraversal' Value Value
-> AffineTraversal' Value Value -> AffineTraversal' Value Value
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
(%) (AffineTraversal' Value Value
 -> AffineTraversal' Value Value -> AffineTraversal' Value Value)
-> (Token -> AffineTraversal' Value Value)
-> Token
-> AffineTraversal' Value Value
-> AffineTraversal' Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> AffineTraversal' Value Value
tokenL) (Optic An_Iso NoIx Value Value Value Value
-> AffineTraversal' Value Value
forall destKind srcKind (is :: IxList) s t a b.
Is srcKind destKind =>
Optic srcKind is s t a b -> Optic destKind is s t a b
castOptic Optic An_Iso NoIx Value Value Value Value
forall a. Iso' a a
simple) ([Token] -> AffineTraversal' Value Value)
-> (Pointer -> [Token]) -> Pointer -> AffineTraversal' Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.tokens)

-- | Access a 'Pointer' like 'at', used for adding or removing
atPointerL :: Pointer -> AffineTraversal' Value (Maybe Value)
atPointerL :: Pointer -> AffineTraversal' Value (Maybe Value)
atPointerL Pointer
p = case Pointer -> Maybe (Pointer, Token)
splitPointer Pointer
p of
  Maybe (Pointer, Token)
Nothing -> Optic A_Prism NoIx Value Value (Maybe Value) (Maybe Value)
-> AffineTraversal' Value (Maybe Value)
forall destKind srcKind (is :: IxList) s t a b.
Is srcKind destKind =>
Optic srcKind is s t a b -> Optic destKind is s t a b
castOptic Optic A_Prism NoIx Value Value (Maybe Value) (Maybe Value)
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
_JSON -- hack to return as-is
  Just (Pointer
parent, Token
t) -> Pointer -> AffineTraversal' Value Value
pointerL Pointer
parent AffineTraversal' Value Value
-> AffineTraversal' Value (Maybe Value)
-> AffineTraversal' Value (Maybe Value)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Token -> AffineTraversal' Value (Maybe Value)
atTokenL Token
t

splitPointer :: Pointer -> Maybe (Pointer, Token)
splitPointer :: Pointer -> Maybe (Pointer, Token)
splitPointer Pointer
p = NonEmpty Token -> (Pointer, Token)
go (NonEmpty Token -> (Pointer, Token))
-> Maybe (NonEmpty Token) -> Maybe (Pointer, Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token] -> Maybe (NonEmpty Token)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty Pointer
p.tokens
 where
  go :: NonEmpty Token -> (Pointer, Token)
go NonEmpty Token
x = ([Token] -> Pointer
Pointer ([Token] -> Pointer) -> [Token] -> Pointer
forall a b. (a -> b) -> a -> b
$ NonEmpty Token -> [Token]
forall a. NonEmpty a -> [a]
NE.init NonEmpty Token
x, NonEmpty Token -> Token
forall a. NonEmpty a -> a
NE.last NonEmpty Token
x)