-- |
--
-- 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 (..)
  , tokenFromText
  , tokenToText
  , tokenL
  , atTokenL
  ) where

import Data.JSON.Patch.Prelude

import Data.Aeson (Key, Value (..))
import Data.Aeson.Key qualified as Key
import Data.Aeson.Optics (key, nth)
import Data.Aeson.Optics.Ext
import Data.Char (isDigit)
import Data.Text qualified as T
import Optics.Core
import Text.Read (readEither)

data Token = N Int | E | K Key
  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)

-- | Access a key or array index like 'ix', used for indexing
tokenL :: Token -> AffineTraversal' Value Value
tokenL :: Token -> AffineTraversal' Value Value
tokenL Token
t = case Token
t of
  N Int
n -> Int -> AffineTraversal' Value Value
forall t. AsValue t => Int -> AffineTraversal' t Value
nth Int
n
  Token
E -> AffineTraversal' Value (Maybe Value)
atEnd AffineTraversal' Value (Maybe Value)
-> Optic A_Prism NoIx (Maybe Value) (Maybe Value) 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
% Optic A_Prism NoIx (Maybe Value) (Maybe Value) Value Value
forall a b. Prism (Maybe a) (Maybe b) a b
_Just
  K Key
k -> Key -> AffineTraversal' Value Value
forall t. AsValue t => Key -> AffineTraversal' t Value
key Key
k

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

tokenFromText :: Text -> Either String Token
tokenFromText :: Text -> Either String Token
tokenFromText = \case
  Text
"" -> Token -> Either String Token
forall a b. b -> Either a b
Right (Token -> Either String Token) -> Token -> Either String Token
forall a b. (a -> b) -> a -> b
$ Key -> Token
K Key
""
  Text
"-" -> Token -> Either String Token
forall a b. b -> Either a b
Right Token
E
  Text
t | (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit Text
t -> Int -> Token
N (Int -> Token) -> Either String Int -> Either String Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String Int
readDigits Text
t
  -- The spec doesn't allow this (negative indexes), but the tests use it to
  -- trigger the lower bounds error example.
  Text
t | Just (Char
'-', Text
n) <- Text -> Maybe (Char, Text)
T.uncons Text
t, (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit Text
n -> Int -> Token
N (Int -> Token) -> (Int -> Int) -> Int -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Num a => a -> a
negate (Int -> Token) -> Either String Int -> Either String Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String Int
readDigits Text
n
  Text
t -> Token -> Either String Token
forall a b. b -> Either a b
Right (Token -> Either String Token) -> Token -> Either String Token
forall a b. (a -> b) -> a -> b
$ Key -> Token
K (Key -> Token) -> Key -> Token
forall a b. (a -> b) -> a -> b
$ Text -> Key
Key.fromText (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"~0" Text
"~" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"~1" Text
"/" Text
t

readDigits :: Text -> Either String Int
readDigits :: Text -> Either String Int
readDigits Text
t
  | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"0" = Int -> Either String Int
forall a b. b -> Either a b
Right Int
0
  | Text -> Text -> Bool
T.isPrefixOf Text
"0" Text
t = String -> Either String Int
forall a b. a -> Either a b
Left String
"leading zeros"
  | Bool
otherwise =
      ShowS -> Either String Int -> Either String Int
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\String
msg -> String
"could not read digits " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg)
        (Either String Int -> Either String Int)
-> Either String Int -> Either String Int
forall a b. (a -> b) -> a -> b
$ String -> Either String Int
forall a. Read a => String -> Either String a
readEither
        (String -> Either String Int) -> String -> Either String Int
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
t

tokenToText :: Token -> Text
tokenToText :: Token -> Text
tokenToText = \case
  K Key
k -> HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"/" Text
"~1" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"~" Text
"~0" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ 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
  Token
E -> Text
"-"