@@ -1,13 +1,18 @@
1+{-# LANGUAGE DeriveGeneric #-}
12{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE OverloadedStrings #-}
24
3−module Data.Aeson.Pointer where
5+module JSONPointer where
46
57import Control.Monad (when)
68import 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)
812import Data.Text (Text)
913import qualified Data.Text as T
1014import qualified Data.Vector as V
15+import GHC.Generics (Generic)
1116import Test.QuickCheck
1217import Text.Read (readMaybe)
1318
@@ -16,9 +21,30 @@ import Control.Applicative
1621import Data.Monoid
1722import Data.Traversable
1823
24+--------------------------------------------------
25+-- * Resolution
26+--------------------------------------------------
27+
28+data ResolutionError
29+ = ObjectLookupFailed
30+ | ArrayIndexInvalid
31+ | ArrayElemNotFound
32+ | ExpectedObjectOrArray
33+ deriving (Eq, Show)
34+
35+resolve :: Pointer -> Value -> Either ResolutionError Value
36+resolve (Pointer []) v = Right v
37+resolve (Pointer (t:ts)) v = resolveToken t v >>= resolve (Pointer ts)
38+
39+--------------------------------------------------
40+-- * Main types and escaping
41+--------------------------------------------------
42+
1943newtype Pointer
2044 = Pointer { _unPointer :: [Token] }
21− deriving (Eq, Show, Monoid, Arbitrary)
45+ deriving (Eq, Show, Semigroup, Monoid, Generic, Arbitrary)
46+
47+instance HA.Hashable Pointer
2248
2349instance FromJSON Pointer where
2450 parseJSON = withText "JSON Pointer" $ \t ->
@@ -32,13 +58,22 @@ instance ToJSON Pointer where
3258-- | We don't try to distinguish between integer tokens and string
3359-- tokens since all tokens start as strings, and all tokens can
3460-- be used to resolve JSON objects.
61+--
62+-- Since these are unescaped you can write @"/"@ and @"~"@ normally.
63+-- (e.g. if you're referencing a key such as @"abc/123"@, go ahead
64+-- and write that exactly.
3565newtype Token
3666 = Token { _unToken :: Text }
37− deriving (Eq, Show)
67+ deriving (Eq, Show, Generic)
68+
69+instance HA.Hashable Token
3870
3971instance Arbitrary Token where
4072 arbitrary = Token . T.pack <$> arbitrary
4173
74+-- | This escapes @"/"@ (because it's the token separator character).
75+--
76+-- It also escapes @"~"@ (because it's the escape character).
4277escape :: Pointer -> Text
4378escape (Pointer []) = ""
4479escape (Pointer ts) =
@@ -47,15 +82,12 @@ escape (Pointer ts) =
4782 . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken)
4883 $ ts
4984
50−-- * Unescaping
51−
5285data FormatError
5386 = InvalidFirstChar
5487 -- ^ JSON Pointers must either be empty or start with a @/@.
5588 | UnescapedTilde
5689 deriving (Eq, Show)
5790
58−
5991-- | JSON Pointers must either be empty or start with a @/@. This means
6092-- that if you're turning a URI Fragment into a JSON Pointer you must
6193-- drop the initial @#@.
@@ -77,7 +109,40 @@ unescape txt =
77109 Nothing -> Left UnescapedTilde
78110 Just tok -> Right tok
79111
80−-- | For internal use by 'unescape'.
112+--------------------------------------------------
113+-- * Wrapper Types
114+--
115+-- These aren't used by the rest of the library
116+-- (as explained in the docs for 'Token').
117+--
118+-- However, they might be useful if you need to distinguish JSON Pointer
119+-- tokens from plain 'Text' or 'Int' without losing information by
120+-- converting to 'Token'.
121+--------------------------------------------------
122+
123+-- | A glorified @type@ alias. If you need to do JSON Pointer operations
124+-- you're looking for 'Token' instead.
125+--
126+-- NOTE: Unlike 'Token' this is escaped.
127+newtype Key
128+ = Key { _unKey :: Text }
129+ deriving (Eq, Show, Generic)
130+
131+instance HA.Hashable Key
132+
133+-- | A glorified @type@ alias. If you need to do JSON Pointer operations
134+-- you're looking for 'Token' instead.
135+newtype Index
136+ = Index { _unIndex :: Int }
137+ deriving (Eq, Show, Generic)
138+
139+instance HA.Hashable Index
140+
141+--------------------------------------------------
142+-- * Internals
143+--------------------------------------------------
144+
145+-- | For internal use (by 'unescape').
81146unescapeToken :: Text -> Maybe Token
82147unescapeToken t
83148 | not (isValid t) = Nothing
@@ -93,21 +158,10 @@ unescapeToken t
93158 replace :: Text -> Text
94159 replace = T.replace "~0" "~" . T.replace "~1" "/"
95160
96−-- * Resolution
97−
98−data ResolutionError
99− = ObjectLookupFailed
100− | ArrayIndexInvalid
101− | ArrayElemNotFound
102− | ExpectedObjectOrArray
103− deriving (Eq, Show)
104−
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)
108−
109−-- | For internal use (or specialized applications that don't want to
110−-- resolve an entire pointer at once).
161+-- | For internal use (by 'resolve').
162+--
163+-- Might also be useful for specialized applications that don't
164+-- want to resolve an entire pointer at once.
111165resolveToken :: Token -> Value -> Either ResolutionError Value
112166resolveToken tok (Array vs) =
113167 case readMaybe . T.unpack . _unToken $ tok of
@@ -118,7 +172,7 @@ resolveToken tok (Array vs) =
118172 Nothing -> Left ArrayElemNotFound
119173 Just res -> Right res
120174resolveToken tok (Object h) =
121− case H.lookup (_unToken tok) h of
175+ case HM.lookup (_unToken tok) h of
122176 Nothing -> Left ObjectLookupFailed
123177 Just res -> Right res
124178resolveToken _ _ = Left ExpectedObjectOrArray