-- |
--
-- Module      : Data.JSON.Pointer.Token
-- Copyright   : (c) 2025 Patrick Brisbin
-- License     : AGPL-3
-- Maintainer  : pbrisbin@gmail.com
-- Stability   : experimental
-- Portability : POSIX
module Data.JSON.Pointer.Token
  ( Token (..)
  , tokenP
  , tokensToText
  , tokensToString
  , tokensL
  , tokenL
  , atTokenL
  ) where

import Prelude

import Control.Applicative (optional, (<|>))
import Data.Aeson (Key, Value (..))
import Data.Aeson.Key qualified as Key
import Data.Aeson.Optics
import Data.Aeson.Optics.Ext
import Data.Attoparsec.Text
import Data.Text (Text, pack, unpack)
import Data.Text qualified as T
import Optics
import Text.Read (readEither)

data Token = K Key | N Int
  deriving stock (Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq, Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> String
show :: Token -> String
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show)

tokensToString :: [Token] -> String
tokensToString :: [Token] -> String
tokensToString = Text -> String
unpack (Text -> String) -> ([Token] -> Text) -> [Token] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Text
tokensToText

tokensToText :: [Token] -> Text
tokensToText :: [Token] -> Text
tokensToText [Token]
ts = Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"/" ((Token -> Text) -> [Token] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Token -> Text
tokenToText [Token]
ts)

tokenToText :: Token -> Text
tokenToText :: Token -> Text
tokenToText = \case
  K Key
k -> Key -> Text
Key.toText Key
k
  N Int
n -> String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
n

tokensL :: [Token] -> AffineTraversal' Value Value
tokensL :: [Token] -> AffineTraversal' Value Value
tokensL = (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) (AffineTraversal' Value Value
 -> [Token] -> AffineTraversal' Value Value)
-> AffineTraversal' Value Value
-> [Token]
-> AffineTraversal' Value Value
forall a b. (a -> b) -> a -> b
$ 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

-- | Access a key or array index like 'ix'
tokenL :: Token -> AffineTraversal' Value Value
tokenL :: Token -> AffineTraversal' Value Value
tokenL Token
t = case Token
t of
  K Key
k -> Key -> AffineTraversal' Value Value
forall t. AsValue t => Key -> AffineTraversal' t Value
key Key
k
  N Int
n -> Int -> AffineTraversal' Value Value
forall t. AsValue t => Int -> AffineTraversal' t Value
nth Int
n

-- | Access a key or array index, but 'at'-like
atTokenL :: Token -> AffineTraversal' Value (Maybe Value)
atTokenL :: Token -> AffineTraversal' Value (Maybe Value)
atTokenL = \case
  K Key
k -> Key -> AffineTraversal' Value (Maybe Value)
atKey Key
k
  N Int
n -> Int -> AffineTraversal' Value (Maybe Value)
atNth Int
n

tokenP :: Parser Token
tokenP :: Parser Token
tokenP = Parser Token
wtf Parser Token -> Parser Token -> Parser Token
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Token
N (Int -> Token) -> Parser Text Int -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int
indexP Parser Token -> Parser Token -> Parser Token
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Key -> Token
K (Key -> Token) -> Parser Text Key -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Key
keyP

-- |
--
-- The tests love to use this value as an example. I'm clearly confused because
-- I would expect it to fail 'indexP', backtrack, then succeed in 'keyP', but it
-- causes errors with "endOfInput", so we'll special case it for now.
wtf :: Parser Token
wtf :: Parser Token
wtf = Key -> Token
K (Key -> Token) -> (Text -> Key) -> Text -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Key
Key.fromText (Text -> Token) -> Parser Text Text -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text Text
string Text
"1e0"

keyP :: Parser Key
keyP :: Parser Text Key
keyP =
  Text -> Key
Key.fromText
    (Text -> Key) -> (Text -> Text) -> Text -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"~0" Text
"~"
    (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"~1" Text
"/"
    (Text -> Key) -> Parser Text Text -> Parser Text Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')

indexP :: Parser Int
indexP :: Parser Text Int
indexP = do
  Int -> Int
f <- (Int -> Int) -> (Char -> Int -> Int) -> Maybe Char -> Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int -> Int
forall a. a -> a
id ((Int -> Int) -> Char -> Int -> Int
forall a b. a -> b -> a
const Int -> Int
forall a. Num a => a -> a
negate) (Maybe Char -> Int -> Int)
-> Parser Text (Maybe Char) -> Parser Text (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Char -> Parser Text (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Text Char
char Char
'-')
  Int -> Int
f (Int -> Int) -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int
nonzeroP Parser Text Int -> Parser Text Int -> Parser Text Int
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int
0 Int -> Parser Text Char -> Parser Text Int
forall a b. a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Text Char
char Char
'0'

nonzeroP :: Parser Int
nonzeroP :: Parser Text Int
nonzeroP = do
  String
ds <- (:) (Char -> ShowS) -> Parser Text Char -> Parser Text ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Char
satisfy (String -> Char -> Bool
inClass String
"1-9") Parser Text ShowS -> Parser Text String -> Parser Text String
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Char -> Parser Text String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Text Char
digit
  (String -> Parser Text Int)
-> (Int -> Parser Text Int) -> Either String Int -> Parser Text Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> String -> Parser Text Int
forall a. String -> String -> Parser a
err String
ds) Int -> Parser Text Int
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Int -> Parser Text Int)
-> Either String Int -> Parser Text Int
forall a b. (a -> b) -> a -> b
$ String -> Either String Int
forall a. Read a => String -> Either String a
readEither String
ds
 where
  err :: String -> String -> Parser a
  err :: forall a. String -> String -> Parser a
err String
x String
msg = String -> Parser Text a
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Text a) -> String -> Parser Text a
forall a b. (a -> b) -> a -> b
$ String
"Unable to read integer from " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg