@@ -4,7 +4,6 @@ import Import hiding ((<>))
5import Data.Aeson.TH (constructorTagModifier)
5import Data.Aeson.TH (constructorTagModifier)
6import Data.Char (toLower)
6import Data.Char (toLower)
7−import qualified Data.HashMap.Strict as HM
8import Data.List.NonEmpty (NonEmpty((:|)))
7import Data.List.NonEmpty (NonEmpty((:|)))
9import qualified Data.List.NonEmpty as NE
8import qualified Data.List.NonEmpty as NE
10import qualified Data.Scientific as SCI
9import qualified Data.Scientific as SCI
@@ -134,7 +133,7 @@ data JSONPointerError
134 deriving (Eq, Show)
133 deriving (Eq, Show)
136resolveFragment
135resolveFragment
137− :: (FromJSON schema, ToJSON schema)
136+ :: forall schema. (FromJSON schema, ToJSON schema)
138 => (BaseURI -> schema -> BaseURI)
137 => (BaseURI -> schema -> BaseURI)
139 -> Scope schema
138 -> Scope schema
@@ -159,40 +158,17 @@ resolveFragment updateScope scope fragment = do
159 -- as property keys that aren't meant to change scope?
158 -- as property keys that aren't meant to change scope?
160 -- Perhaps this should be added to the language agnostic
159 -- Perhaps this should be added to the language agnostic
161 -- test suite as well.
160 -- test suite as well.
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.
167 go :: (Value, BaseURI)
161 go :: (Value, BaseURI)
168 -> JP.Token
162 -> JP.Token
169 -> Either JSONPointerError (Value, BaseURI)
163 -> Either JSONPointerError (Value, BaseURI)
170− go (lastVal, baseURI) tok = do
164+ go (lastVal, uri) tok = do
171 v <- first ResolutionError (JP.resolveToken tok lastVal)
165 v <- first ResolutionError (JP.resolveToken tok lastVal)
172− newBase <- newBaseURIFromFragment updateScope baseURI v
166+ case v of
173− Right (v, newBase)
167+ Array _ -> pure (v, uri)
175−-- | Update the 'BaseURI' (the store of the current "id" value)
169+ -- PERFORMANCE: Avoid deserializing subschemas.
176−-- after resolving one token of a JSON Pointer and stepping into
178−newBaseURIFromFragment
180− => (BaseURI -> schema -> BaseURI)
183− -> Either JSONPointerError BaseURI
184−newBaseURIFromFragment updateScope baseURI v =
187− let hmWithOnlyId = case HM.lookup idKey hm of
189− Just idVal -> HM.singleton idKey idVal
190− schema <- first SubschemaDecodingError (fromJSONEither (Object hmWithOnlyId))
170+ schema <- first SubschemaDecodingError (fromJSONEither v)
191− Right (updateScope baseURI schema)
171+ pure (v, updateScope uri schema)
197--------------------------------------------------
173--------------------------------------------------