@@ -1,24 +1,44 @@
1+{-# LANGUAGE DeriveGeneric #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE OverloadedStrings #-}
3−module Data.Aeson.Pointer where
5+module JSONPointer where
5import Control.Monad (when)
7import Control.Monad (when)
6import Data.Aeson
8import Data.Aeson
7−import qualified Data.HashMap.Strict as H
9+import qualified Data.Hashable as HA
10+import qualified Data.HashMap.Strict as HM
11+import Data.Semigroup (Semigroup)
8import Data.Text (Text)
12import Data.Text (Text)
9import qualified Data.Text as T
13import qualified Data.Text as T
10import qualified Data.Vector as V
14import qualified Data.Vector as V
11−import Test.QuickCheck
15+import GHC.Generics (Generic)
12import Text.Read (readMaybe)
16import Text.Read (readMaybe)
14−-- For GHCs before 7.10:
18+--------------------------------------------------
15−import Control.Applicative
19+-- * Resolution
16−import Data.Monoid
20+--------------------------------------------------
17−import Data.Traversable
21+
26+ | ExpectedObjectOrArray
29+resolve :: Pointer -> Value -> Either ResolutionError Value
30+resolve (Pointer []) v = Right v
31+resolve (Pointer (t:ts)) v = resolveToken t v >>= resolve (Pointer ts)
33+--------------------------------------------------
34+-- * Main types and escaping
35+--------------------------------------------------
19newtype Pointer
37newtype Pointer
20 = Pointer { _unPointer :: [Token] }
38 = Pointer { _unPointer :: [Token] }
21− deriving (Eq, Show, Monoid, Arbitrary)
39+ deriving (Eq, Show, Semigroup, Monoid, Generic)
41+instance HA.Hashable Pointer
23instance FromJSON Pointer where
43instance FromJSON Pointer where
24 parseJSON = withText "JSON Pointer" $ \t ->
44 parseJSON = withText "JSON Pointer" $ \t ->
@@ -32,13 +52,19 @@ instance ToJSON Pointer where
32-- | We don't try to distinguish between integer tokens and string
52-- | We don't try to distinguish between integer tokens and string
33-- tokens since all tokens start as strings, and all tokens can
53-- tokens since all tokens start as strings, and all tokens can
34-- be used to resolve JSON objects.
54-- be used to resolve JSON objects.
56+-- Since these are unescaped you can write @"/"@ and @"~"@ normally.
57+-- (e.g. if you're referencing a key such as @"abc/123"@, go ahead
58+-- and write that exactly.
35newtype Token
59newtype Token
36 = Token { _unToken :: Text }
60 = Token { _unToken :: Text }
37− deriving (Eq, Show)
61+ deriving (Eq, Show, Generic)
39−instance Arbitrary Token where
63+instance HA.Hashable Token
40− arbitrary = Token . T.pack <$> arbitrary
65+-- | This escapes @"/"@ (because it's the token separator character).
67+-- It also escapes @"~"@ (because it's the escape character).
42escape :: Pointer -> Text
68escape :: Pointer -> Text
43escape (Pointer []) = ""
69escape (Pointer []) = ""
44escape (Pointer ts) =
70escape (Pointer ts) =
@@ -47,15 +73,12 @@ escape (Pointer ts) =
47 . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken)
73 . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken)
52data FormatError
76data FormatError
53 = InvalidFirstChar
77 = InvalidFirstChar
54 -- ^ JSON Pointers must either be empty or start with a @/@.
78 -- ^ JSON Pointers must either be empty or start with a @/@.
55 | UnescapedTilde
79 | UnescapedTilde
56 deriving (Eq, Show)
80 deriving (Eq, Show)
59-- | JSON Pointers must either be empty or start with a @/@. This means
82-- | JSON Pointers must either be empty or start with a @/@. This means
60-- that if you're turning a URI Fragment into a JSON Pointer you must
83-- that if you're turning a URI Fragment into a JSON Pointer you must
61-- drop the initial @#@.
84-- drop the initial @#@.
@@ -77,7 +100,40 @@ unescape txt =
77 Nothing -> Left UnescapedTilde
100 Nothing -> Left UnescapedTilde
78 Just tok -> Right tok
101 Just tok -> Right tok
103+--------------------------------------------------
106+-- $ These aren't used by the rest of the library
107+-- (as explained in the docs for 'Token').
109+-- However, they might be useful if you need to distinguish JSON Pointer
110+-- tokens from plain 'Text' or 'Int' without losing information by
111+-- converting to 'Token'.
112+--------------------------------------------------
114+-- | A glorified @type@ alias. If you need to do JSON Pointer operations
115+-- you're looking for 'Token' instead.
117+-- NOTE: Unlike 'Token' this is escaped.
119+ = Key { _unKey :: Text }
120+ deriving (Eq, Show, Generic)
122+instance HA.Hashable Key
124+-- | A glorified @type@ alias. If you need to do JSON Pointer operations
125+-- you're looking for 'Token' instead.
127+ = Index { _unIndex :: Int }
128+ deriving (Eq, Show, Generic)
130+instance HA.Hashable Index
132+--------------------------------------------------
134+--------------------------------------------------
80−-- | For internal use by 'unescape'.
136+-- | For internal use (by 'unescape').
81unescapeToken :: Text -> Maybe Token
137unescapeToken :: Text -> Maybe Token
82unescapeToken t
138unescapeToken t
83 | not (isValid t) = Nothing
139 | not (isValid t) = Nothing
@@ -93,21 +149,10 @@ unescapeToken t
93 replace :: Text -> Text
149 replace :: Text -> Text
94 replace = T.replace "~0" "~" . T.replace "~1" "/"
150 replace = T.replace "~0" "~" . T.replace "~1" "/"
96−-- * Resolution
152+-- | For internal use (by 'resolve').
102− | ExpectedObjectOrArray
105−resolve :: Pointer -> Value -> Either ResolutionError Value
106−resolve (Pointer []) v = Right v
107−resolve (Pointer (t:ts)) v = resolveToken t v >>= resolve (Pointer ts)
109−-- | For internal use (or specialized applications that don't want to
154+-- Might also be useful for specialized applications that don't
110−-- resolve an entire pointer at once).
155+-- want to resolve an entire pointer at once.
111resolveToken :: Token -> Value -> Either ResolutionError Value
156resolveToken :: Token -> Value -> Either ResolutionError Value
112resolveToken tok (Array vs) =
157resolveToken tok (Array vs) =
113 case readMaybe . T.unpack . _unToken $ tok of
158 case readMaybe . T.unpack . _unToken $ tok of
@@ -118,7 +163,7 @@ resolveToken tok (Array vs) =
118 Nothing -> Left ArrayElemNotFound
163 Nothing -> Left ArrayElemNotFound
119 Just res -> Right res
164 Just res -> Right res
120resolveToken tok (Object h) =
165resolveToken tok (Object h) =
121− case H.lookup (_unToken tok) h of
166+ case HM.lookup (_unToken tok) h of
122 Nothing -> Left ObjectLookupFailed
167 Nothing -> Left ObjectLookupFailed
123 Just res -> Right res
168 Just res -> Right res
124resolveToken _ _ = Left ExpectedObjectOrArray
169resolveToken _ _ = Left ExpectedObjectOrArray