@@ -4,7 +4,6 @@ import Import hiding ((<>))
44
55import Data.Aeson.TH (constructorTagModifier)
66import Data.Char (toLower)
7−import qualified Data.HashMap.Strict as HM
87import Data.List.NonEmpty (NonEmpty((:|)))
98import qualified Data.List.NonEmpty as NE
109import qualified Data.Scientific as SCI
@@ -134,7 +133,7 @@ data JSONPointerError
134133 deriving (Eq, Show)
135134
136135resolveFragment
137− :: (FromJSON schema, ToJSON schema)
136+ :: forall schema. (FromJSON schema, ToJSON schema)
138137 => (BaseURI -> schema -> BaseURI)
139138 -> Scope schema
140139 -> Text
@@ -159,40 +158,17 @@ resolveFragment updateScope scope fragment = do
159158 -- as property keys that aren't meant to change scope?
160159 -- Perhaps this should be added to the language agnostic
161160 -- test suite as well.
162− --
163− -- In the meantime 'newBaseURIFromFragment' drops all keys
164− -- from JSON objects except "id", which at least prevents
165− -- SubschemaDecodingError in a situation where one of the
166− -- values we step through isn't a valid schema.
167161 go :: (Value, BaseURI)
168162 -> JP.Token
169163 -> Either JSONPointerError (Value, BaseURI)
170− go (lastVal, baseURI) tok = do
164+ go (lastVal, uri) tok = do
171165 v <- first ResolutionError (JP.resolveToken tok lastVal)
172− newBase <- newBaseURIFromFragment updateScope baseURI v
173− Right (v, newBase)
174−
175−-- | Update the 'BaseURI' (the store of the current "id" value)
176−-- after resolving one token of a JSON Pointer and stepping into
177−-- a new 'Value'.
178−newBaseURIFromFragment
179− :: FromJSON schema
180− => (BaseURI -> schema -> BaseURI)
181− -> BaseURI
182− -> Value
183− -> Either JSONPointerError BaseURI
184−newBaseURIFromFragment updateScope baseURI v =
185− case v of
186− Object hm -> do
187− let hmWithOnlyId = case HM.lookup idKey hm of
188− Nothing -> mempty
189− Just idVal -> HM.singleton idKey idVal
190− schema <- first SubschemaDecodingError (fromJSONEither (Object hmWithOnlyId))
191− Right (updateScope baseURI schema)
192− _ -> Right baseURI
193− where
194− idKey :: Text
195− idKey = "id"
166+ case v of
167+ Array _ -> pure (v, uri)
168+ _ -> do
169+ -- PERFORMANCE: Avoid deserializing subschemas.
170+ schema <- first SubschemaDecodingError (fromJSONEither v)
171+ pure (v, updateScope uri schema)
196172
197173--------------------------------------------------
198174-- * enum