    {-# 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