-- |
--
-- 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.Attoparsec.Text
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 = Parser Pointer -> Text -> Either String Pointer
forall a. Parser a -> Text -> Either String a
parseOnly Parser Pointer
pointerP

pointerP :: Parser Pointer
pointerP :: Parser Pointer
pointerP = do
  [Token]
ts <- (Char -> Parser Char
char Char
'/' Parser Char -> Parser Text [Token] -> Parser Text [Token]
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Token
tokenP Parser Token -> Parser Char -> Parser Text [Token]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Char -> Parser Char
char Char
'/' Parser Text [Token] -> Parser Text [Token] -> Parser Text [Token]
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Token] -> Parser Text [Token]
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Parser Text [Token] -> Parser Text () -> Parser Text [Token]
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput
  Pointer -> Parser Pointer
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pointer -> Parser Pointer) -> Pointer -> Parser Pointer
forall a b. (a -> b) -> a -> b
$ [Token] -> Pointer
Pointer [Token]
ts

tokenP :: Parser Token
tokenP :: Parser Token
tokenP =
  (String -> Parser Token)
-> (Token -> Parser Token) -> Either String Token -> Parser Token
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser Token
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Token) -> ShowS -> String -> Parser Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"invalid token: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>)) Token -> Parser Token
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Either String Token -> Parser Token)
-> (Text -> Either String Token) -> Text -> Parser Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Token
tokenFromText
    (Text -> Parser Token) -> Parser Text Text -> Parser Token
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Char -> Bool) -> Parser Text Text
takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')

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)