{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
-- | Description: JSON Pointers as described in RFC 6901.
module Data.Aeson.Pointer (
  Pointer(..),
  Key(..),
  Path,
  -- * Representing pointers
  formatPointer,
  parsePointer,
  -- * Using pointers
  get,
  pointerFailure,
) where

import           Data.Aeson (encode)
import qualified Data.Aeson.Key (Key)
import           Data.Aeson.Key (fromText, toText)
import qualified Data.Aeson.KeyMap as HM
import           Data.Aeson.Types (FromJSON(parseJSON), Parser, Result(Error), ToJSON(toJSON), Value(Array, Object, Number, String), modifyFailure)
import qualified Data.ByteString.Lazy.Char8 as BS
import           Data.Char                  (isNumber)
import           Data.Scientific            (toBoundedInteger)
import           Data.Text                  (Text)
import qualified Data.Text                  as T
import qualified Data.Vector                as V
import           GHC.Generics               (Generic)

-- * Patch components

-- | Path components to traverse a single layer of a JSON document.
data Key
    = OKey Data.Aeson.Key.Key -- ^ Traverse a 'Value' with an 'Object' constructor.
    | AKey Int                -- ^ Traverse a 'Value' with an 'Array' constructor.
  deriving (Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
/= :: Key -> Key -> Bool
Eq, Eq Key
Eq Key =>
(Key -> Key -> Ordering)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Key)
-> (Key -> Key -> Key)
-> Ord Key
Key -> Key -> Bool
Key -> Key -> Ordering
Key -> Key -> Key
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Key -> Key -> Ordering
compare :: Key -> Key -> Ordering
$c< :: Key -> Key -> Bool
< :: Key -> Key -> Bool
$c<= :: Key -> Key -> Bool
<= :: Key -> Key -> Bool
$c> :: Key -> Key -> Bool
> :: Key -> Key -> Bool
$c>= :: Key -> Key -> Bool
>= :: Key -> Key -> Bool
$cmax :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
min :: Key -> Key -> Key
Ord, Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Key -> ShowS
showsPrec :: Int -> Key -> ShowS
$cshow :: Key -> String
show :: Key -> String
$cshowList :: [Key] -> ShowS
showList :: [Key] -> ShowS
Show, (forall x. Key -> Rep Key x)
-> (forall x. Rep Key x -> Key) -> Generic Key
forall x. Rep Key x -> Key
forall x. Key -> Rep Key x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Key -> Rep Key x
from :: forall x. Key -> Rep Key x
$cto :: forall x. Rep Key x -> Key
to :: forall x. Rep Key x -> Key
Generic)

instance ToJSON Key where
    toJSON :: Key -> Value
toJSON (OKey Key
t) = Key -> Value
forall a. ToJSON a => a -> Value
toJSON Key
t
    toJSON (AKey Int
a) = Scientific -> Value
Number (Scientific -> Value) -> (Int -> Scientific) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Scientific) -> (Int -> Integer) -> Int -> Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ Int
a

instance FromJSON Key where
    parseJSON :: Value -> Parser Key
parseJSON (String Text
t) = Key -> Parser Key
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> Parser Key) -> (Text -> Key) -> Text -> Parser Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Key
OKey (Key -> Key) -> (Text -> Key) -> Text -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Key
fromText (Text -> Parser Key) -> Text -> Parser Key
forall a b. (a -> b) -> a -> b
$ Text
t
    parseJSON (Number Scientific
n) =
        case Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
n of
            Maybe Int
Nothing -> String -> Parser Key
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"A numeric key must be a positive whole number."
            Just Int
n' -> Key -> Parser Key
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> Parser Key) -> Key -> Parser Key
forall a b. (a -> b) -> a -> b
$ Int -> Key
AKey Int
n'
    parseJSON Value
_ = String -> Parser Key
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"A key element must be a number or a string."

formatKey :: Key -> Text
formatKey :: Key -> Text
formatKey (AKey Int
i) = String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
i)
formatKey (OKey Key
t) = (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
esc (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Key -> Text
toText Key
t
  where
    esc :: Char -> Text
    esc :: Char -> Text
esc Char
'~' = Text
"~0"
    esc Char
'/' = Text
"~1"
    esc Char
c = Char -> Text
T.singleton Char
c

-- * Pointers

-- | A sequence of 'Key's forms a path through a JSON document.
type Path = [Key]

-- | Pointer to a location in a JSON document.
--
-- Defined in RFC 6901 <http://tools.ietf.org/html/rfc6901>
newtype Pointer = Pointer { Pointer -> [Key]
pointerPath :: Path }
  deriving (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, Eq Pointer
Eq Pointer =>
(Pointer -> Pointer -> Ordering)
-> (Pointer -> Pointer -> Bool)
-> (Pointer -> Pointer -> Bool)
-> (Pointer -> Pointer -> Bool)
-> (Pointer -> Pointer -> Bool)
-> (Pointer -> Pointer -> Pointer)
-> (Pointer -> Pointer -> Pointer)
-> Ord Pointer
Pointer -> Pointer -> Bool
Pointer -> Pointer -> Ordering
Pointer -> Pointer -> Pointer
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Pointer -> Pointer -> Ordering
compare :: Pointer -> Pointer -> Ordering
$c< :: Pointer -> Pointer -> Bool
< :: Pointer -> Pointer -> Bool
$c<= :: Pointer -> Pointer -> Bool
<= :: Pointer -> Pointer -> Bool
$c> :: Pointer -> Pointer -> Bool
> :: Pointer -> Pointer -> Bool
$c>= :: Pointer -> Pointer -> Bool
>= :: Pointer -> Pointer -> Bool
$cmax :: Pointer -> Pointer -> Pointer
max :: Pointer -> Pointer -> Pointer
$cmin :: Pointer -> Pointer -> Pointer
min :: Pointer -> Pointer -> Pointer
Ord, 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, NonEmpty Pointer -> Pointer
Pointer -> Pointer -> Pointer
(Pointer -> Pointer -> Pointer)
-> (NonEmpty Pointer -> Pointer)
-> (forall b. Integral b => b -> Pointer -> Pointer)
-> Semigroup Pointer
forall b. Integral b => b -> Pointer -> Pointer
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Pointer -> Pointer -> Pointer
<> :: Pointer -> Pointer -> Pointer
$csconcat :: NonEmpty Pointer -> Pointer
sconcat :: NonEmpty Pointer -> Pointer
$cstimes :: forall b. Integral b => b -> Pointer -> Pointer
stimes :: forall b. Integral b => b -> Pointer -> Pointer
Semigroup, Semigroup Pointer
Pointer
Semigroup Pointer =>
Pointer
-> (Pointer -> Pointer -> Pointer)
-> ([Pointer] -> Pointer)
-> Monoid Pointer
[Pointer] -> Pointer
Pointer -> Pointer -> Pointer
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Pointer
mempty :: Pointer
$cmappend :: Pointer -> Pointer -> Pointer
mappend :: Pointer -> Pointer -> Pointer
$cmconcat :: [Pointer] -> Pointer
mconcat :: [Pointer] -> Pointer
Monoid, (forall x. Pointer -> Rep Pointer x)
-> (forall x. Rep Pointer x -> Pointer) -> Generic Pointer
forall x. Rep Pointer x -> Pointer
forall x. Pointer -> Rep Pointer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Pointer -> Rep Pointer x
from :: forall x. Pointer -> Rep Pointer x
$cto :: forall x. Rep Pointer x -> Pointer
to :: forall x. Rep Pointer x -> Pointer
Generic)

-- | Format a 'Pointer' as described in RFC 6901.
--
-- >>> formatPointer (Pointer [])
-- ""
-- >>> formatPointer (Pointer [OKey ""])
-- "/"
-- >>> formatPointer (Pointer [OKey " "])
-- "/ "
-- >>> formatPointer (Pointer [OKey "foo"])
-- "/foo"
-- >>> formatPointer (Pointer [OKey "foo", AKey 0])
-- "/foo/0"
-- >>> formatPointer (Pointer [OKey "a/b"])
-- "/a~1b"
-- >>> formatPointer (Pointer [OKey "c%d"])
-- "/c%d"
-- >>> formatPointer (Pointer [OKey "e^f"])
-- "/e^f"
-- >>> formatPointer (Pointer [OKey "g|h"])
-- "/g|h"
-- >>> formatPointer (Pointer [OKey "i\\j"])
-- "/i\\j"
-- >>> formatPointer (Pointer [OKey "k\"l"])
-- "/k\"l"
-- >>> formatPointer (Pointer [OKey "m~n"])
-- "/m~0n"
formatPointer :: Pointer -> Text
formatPointer :: Pointer -> Text
formatPointer (Pointer []) = Text
""
formatPointer (Pointer [Key]
path) = Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"/" (Key -> Text
formatKey (Key -> Text) -> [Key] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Key]
path)

-- | Parse a 'Pointer' as described in RFC 6901.
parsePointer :: Text -> Parser Pointer
parsePointer :: Text -> Parser Pointer
parsePointer Text
t
  | Text -> Bool
T.null Text
t = Pointer -> Parser Pointer
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Key] -> Pointer
Pointer [])
  | Bool
otherwise = [Key] -> Pointer
Pointer ([Key] -> Pointer) -> Parser [Key] -> Parser Pointer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser Key) -> [Text] -> Parser [Key]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Text -> Parser Key
forall {m :: * -> *}. MonadFail m => Text -> m Key
key (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
t)
  where
    step :: Text -> Text
step Text
t
      | Text
"0" Text -> Text -> Bool
`T.isPrefixOf` Text
t = Char -> Text -> Text
T.cons Char
'~' (HasCallStack => Text -> Text
Text -> Text
T.tail Text
t)
      | Text
"1" Text -> Text -> Bool
`T.isPrefixOf` Text
t = Char -> Text -> Text
T.cons Char
'/' (HasCallStack => Text -> Text
Text -> Text
T.tail Text
t)
      | Bool
otherwise = Char -> Text -> Text
T.cons Char
'~' Text
t
    unesc :: Text -> Text
    unesc :: Text -> Text
unesc Text
t =
      let l :: [Text]
l = (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'~') Text
t
      in [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
1 [Text]
l [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
step ([Text] -> [Text]
forall a. HasCallStack => [a] -> [a]
tail [Text]
l)
    key :: Text -> m Key
key Text
t
      | Text -> Bool
T.null Text
t         = String -> m Key
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"JSON components must not be empty."
      | (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isNumber Text
t = Key -> m Key
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Key
AKey (String -> Int
forall a. Read a => String -> a
read (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t))
      | Bool
otherwise        = Key -> m Key
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> m Key) -> (Text -> Key) -> Text -> m Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Key
OKey (Key -> Key) -> (Text -> Key) -> Text -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Key
fromText (Text -> m Key) -> Text -> m Key
forall a b. (a -> b) -> a -> b
$ Text -> Text
unesc Text
t

instance ToJSON Pointer where
    toJSON :: Pointer -> Value
toJSON Pointer
pointer =
        Text -> Value
String (Pointer -> Text
formatPointer Pointer
pointer)

instance FromJSON Pointer where
    parseJSON :: Value -> Parser Pointer
parseJSON = ShowS -> Parser Pointer -> Parser Pointer
forall a. ShowS -> Parser a -> Parser a
modifyFailure (String
"Could not parse JSON pointer: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) (Parser Pointer -> Parser Pointer)
-> (Value -> Parser Pointer) -> Value -> Parser Pointer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Pointer
parse
      where
        parse :: Value -> Parser Pointer
parse (String Text
t) = Text -> Parser Pointer
parsePointer Text
t
        parse Value
_ = String -> Parser Pointer
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"A JSON pointer must be a string."

-- | Follow a 'Pointer' through a JSON document as described in RFC 6901.
get :: Pointer -> Value -> Result Value
get :: Pointer -> Value -> Result Value
get (Pointer []) Value
v = Value -> Result Value
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
get (Pointer (AKey Int
i : [Key]
path)) (Array Array
v) =
  Result Value
-> (Value -> Result Value) -> Maybe Value -> Result Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Result Value
forall a. String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"") Value -> Result Value
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return (Array
v Array -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
V.!? Int
i) Result Value -> (Value -> Result Value) -> Result Value
forall a b. Result a -> (a -> Result b) -> Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pointer -> Value -> Result Value
get ([Key] -> Pointer
Pointer [Key]
path)
get (Pointer (OKey Key
n : [Key]
path)) (Object Object
v) =
  Result Value
-> (Value -> Result Value) -> Maybe Value -> Result Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Result Value
forall a. String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"") Value -> Result Value
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
HM.lookup Key
n Object
v) Result Value -> (Value -> Result Value) -> Result Value
forall a b. Result a -> (a -> Result b) -> Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pointer -> Value -> Result Value
get ([Key] -> Pointer
Pointer [Key]
path)
get Pointer
pointer Value
value = Pointer -> Value -> Result Value
forall a. Pointer -> Value -> Result a
pointerFailure Pointer
pointer Value
value

-- | Report an error while following a pointer.
pointerFailure :: Pointer -> Value -> Result a
pointerFailure :: forall a. Pointer -> Value -> Result a
pointerFailure (Pointer []) Value
_value = String -> Result a
forall a. String -> Result a
Error String
"Cannot follow empty pointer. This is impossible."
pointerFailure (Pointer path :: [Key]
path@(Key
key:[Key]
_)) Value
value =
    String -> Result a
forall a. String -> Result a
Error (String -> Result a)
-> (ByteString -> String) -> ByteString -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS.unpack (ByteString -> Result a) -> ByteString -> Result a
forall a b. (a -> b) -> a -> b
$ ByteString
"Cannot follow pointer " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pt ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
". Expected " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ty ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" but got " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
doc
  where
    doc :: ByteString
doc = Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
value
    pt :: ByteString
pt = [Key] -> ByteString
forall a. ToJSON a => a -> ByteString
encode [Key]
path
    ty :: ByteString
ty = case Key
key of
           (AKey Int
_) -> ByteString
"array"
           (OKey Key
_) -> ByteString
"object"


-- $setup
-- >>> :set -XOverloadedStrings