-- <https://datatracker.ietf.org/doc/html/rfc6901/>
module Data.JSON.Pointer
  ( Pointer (..)
  , pointerFromText
  , pointerToText
  , pointerToString
  ) where

import Prelude

import Data.Aeson (FromJSON (..), withText)
import Data.Attoparsec.Text
import Data.JSON.Pointer.Token
import Data.List.NonEmpty (nonEmpty)
import Data.List.NonEmpty qualified as NE
import Data.Text (Text, unpack)
import Data.Text qualified as T

data Pointer
  = -- | @""@ means whole-document
    PointerEmpty
  | -- | @"/[.../]x"@ means path to a key or index @x@
    --
    -- NB. @"/"@ naturally becomes @'PointerPath' [] ('K' "")@
    PointerPath [Token] Token
  | -- | @"/[.../]-"@ means path to last element of an array
    PointerPathEnd [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 = \case
  Text
"" -> Pointer -> Either String Pointer
forall a b. b -> Either a b
Right Pointer
PointerEmpty
  Text
"/" -> Pointer -> Either String Pointer
forall a b. b -> Either a b
Right (Pointer -> Either String Pointer)
-> Pointer -> Either String Pointer
forall a b. (a -> b) -> a -> b
$ [Token] -> Token -> Pointer
PointerPath [] (Token -> Pointer) -> Token -> Pointer
forall a b. (a -> b) -> a -> b
$ Key -> Token
K Key
""
  Text
"/-" -> Pointer -> Either String Pointer
forall a b. b -> Either a b
Right (Pointer -> Either String Pointer)
-> Pointer -> Either String Pointer
forall a b. (a -> b) -> a -> b
$ [Token] -> Pointer
PointerPathEnd []
  Text
p -> case Text -> Text -> Maybe Text
T.stripSuffix Text
"/-" Text
p of
    Maybe Text
Nothing -> Parser Pointer -> Text -> Either String Pointer
forall a. Parser a -> Text -> Either String a
parseOnly Parser Pointer
pointerPathP Text
p
    Just Text
p' -> Parser Pointer -> Text -> Either String Pointer
forall a. Parser a -> Text -> Either String a
parseOnly Parser Pointer
pointerPathEndP Text
p'

pointerToText :: Pointer -> Text
pointerToText :: Pointer -> Text
pointerToText = \case
  Pointer
PointerEmpty -> Text
""
  PointerPath [Token]
ts Token
t -> [Token] -> Text
tokensToText ([Token] -> Text) -> [Token] -> Text
forall a b. (a -> b) -> a -> b
$ [Token]
ts [Token] -> [Token] -> [Token]
forall a. Semigroup a => a -> a -> a
<> [Token
t]
  PointerPathEnd [Token]
ts -> [Token] -> Text
tokensToText [Token]
ts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/-"

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

pointerPathP :: Parser Pointer
pointerPathP :: Parser Pointer
pointerPathP = do
  NonEmpty Token
ts <- Parser Text (NonEmpty Token)
-> (NonEmpty Token -> Parser Text (NonEmpty Token))
-> Maybe (NonEmpty Token)
-> Parser Text (NonEmpty Token)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser Text (NonEmpty Token)
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"") NonEmpty Token -> Parser Text (NonEmpty Token)
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (NonEmpty Token) -> Parser Text (NonEmpty Token))
-> ([Token] -> Maybe (NonEmpty Token))
-> [Token]
-> Parser Text (NonEmpty Token)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Maybe (NonEmpty Token)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Token] -> Parser Text (NonEmpty Token))
-> Parser Text [Token] -> Parser Text (NonEmpty Token)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser Text [Token]
pointerP
  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] -> Token -> Pointer
PointerPath (NonEmpty Token -> [Token]
forall a. NonEmpty a -> [a]
NE.init NonEmpty Token
ts) (Token -> Pointer) -> Token -> Pointer
forall a b. (a -> b) -> a -> b
$ NonEmpty Token -> Token
forall a. NonEmpty a -> a
NE.last NonEmpty Token
ts

pointerPathEndP :: Parser Pointer
pointerPathEndP :: Parser Pointer
pointerPathEndP = [Token] -> Pointer
PointerPathEnd ([Token] -> Pointer) -> Parser Text [Token] -> Parser Pointer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text [Token]
pointerP

pointerP :: Parser [Token]
pointerP :: Parser Text [Token]
pointerP = 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 () -> 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