@@ -1,44 +1,24 @@
1−{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE OverloadedStrings #-}
5−module JSONPointer where
3+module Data.Aeson.Pointer where
7import Control.Monad (when)
5import Control.Monad (when)
8import Data.Aeson
6import Data.Aeson
9−import qualified Data.Hashable as HA
7+import qualified Data.HashMap.Strict as H
10−import qualified Data.HashMap.Strict as HM
11−import Data.Semigroup (Semigroup)
12import Data.Text (Text)
8import Data.Text (Text)
13import qualified Data.Text as T
9import qualified Data.Text as T
14import qualified Data.Vector as V
10import qualified Data.Vector as V
15−import GHC.Generics (Generic)
11+import Test.QuickCheck
16import Text.Read (readMaybe)
12import Text.Read (readMaybe)
18−--------------------------------------------------
14+-- For GHCs before 7.10:
19−-- * Resolution
15+import Control.Applicative
20−--------------------------------------------------
16+import Data.Monoid
21−
17+import Data.Traversable
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−--------------------------------------------------
37newtype Pointer
19newtype Pointer
38 = Pointer { _unPointer :: [Token] }
20 = Pointer { _unPointer :: [Token] }
39− deriving (Eq, Show, Semigroup, Monoid, Generic)
21+ deriving (Eq, Show, Monoid, Arbitrary)
41−instance HA.Hashable Pointer
43instance FromJSON Pointer where
23instance FromJSON Pointer where
44 parseJSON = withText "JSON Pointer" $ \t ->
24 parseJSON = withText "JSON Pointer" $ \t ->
@@ -52,19 +32,13 @@ instance ToJSON Pointer where
52-- | We don't try to distinguish between integer tokens and string
32-- | We don't try to distinguish between integer tokens and string
53-- tokens since all tokens start as strings, and all tokens can
33-- tokens since all tokens start as strings, and all tokens can
54-- be used to resolve JSON objects.
34-- 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.
59newtype Token
35newtype Token
60 = Token { _unToken :: Text }
36 = Token { _unToken :: Text }
61− deriving (Eq, Show, Generic)
37+ deriving (Eq, Show)
63−instance HA.Hashable Token
39+instance Arbitrary Token where
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).
68escape :: Pointer -> Text
42escape :: Pointer -> Text
69escape (Pointer []) = ""
43escape (Pointer []) = ""
70escape (Pointer ts) =
44escape (Pointer ts) =
@@ -73,12 +47,15 @@ escape (Pointer ts) =
73 . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken)
47 . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken)
76data FormatError
52data FormatError
77 = InvalidFirstChar
53 = InvalidFirstChar
78 -- ^ JSON Pointers must either be empty or start with a @/@.
54 -- ^ JSON Pointers must either be empty or start with a @/@.
79 | UnescapedTilde
55 | UnescapedTilde
80 deriving (Eq, Show)
56 deriving (Eq, Show)
82-- | JSON Pointers must either be empty or start with a @/@. This means
59-- | JSON Pointers must either be empty or start with a @/@. This means
83-- that if you're turning a URI Fragment into a JSON Pointer you must
60-- that if you're turning a URI Fragment into a JSON Pointer you must
84-- drop the initial @#@.
61-- drop the initial @#@.
@@ -100,40 +77,7 @@ unescape txt =
100 Nothing -> Left UnescapedTilde
77 Nothing -> Left UnescapedTilde
101 Just tok -> Right tok
78 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−--------------------------------------------------
136−-- | For internal use (by 'unescape').
80+-- | For internal use by 'unescape'.
137unescapeToken :: Text -> Maybe Token
81unescapeToken :: Text -> Maybe Token
138unescapeToken t
82unescapeToken t
139 | not (isValid t) = Nothing
83 | not (isValid t) = Nothing
@@ -149,10 +93,21 @@ unescapeToken t
149 replace :: Text -> Text
93 replace :: Text -> Text
150 replace = T.replace "~0" "~" . T.replace "~1" "/"
94 replace = T.replace "~0" "~" . T.replace "~1" "/"
152−-- | For internal use (by 'resolve').
96+-- * Resolution
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)
154−-- Might also be useful for specialized applications that don't
109+-- | For internal use (or specialized applications that don't want to
155−-- want to resolve an entire pointer at once.
110+-- resolve an entire pointer at once).
156resolveToken :: Token -> Value -> Either ResolutionError Value
111resolveToken :: Token -> Value -> Either ResolutionError Value
157resolveToken tok (Array vs) =
112resolveToken tok (Array vs) =
158 case readMaybe . T.unpack . _unToken $ tok of
113 case readMaybe . T.unpack . _unToken $ tok of
@@ -163,7 +118,7 @@ resolveToken tok (Array vs) =
163 Nothing -> Left ArrayElemNotFound
118 Nothing -> Left ArrayElemNotFound
164 Just res -> Right res
119 Just res -> Right res
165resolveToken tok (Object h) =
120resolveToken tok (Object h) =
166− case HM.lookup (_unToken tok) h of
121+ case H.lookup (_unToken tok) h of
167 Nothing -> Left ObjectLookupFailed
122 Nothing -> Left ObjectLookupFailed
168 Just res -> Right res
123 Just res -> Right res
169resolveToken _ _ = Left ExpectedObjectOrArray
124resolveToken _ _ = Left ExpectedObjectOrArray