diff --git a/Example.hs b/Example.hs
--- a/Example.hs
+++ b/Example.hs
@@ -13,14 +13,24 @@
 
 import qualified Data.JsonSchema as JS
 
--- Data.JsonSchema isn't designed to be imported qualified,
--- but we're doing it here to make it obvious what's coming
--- from the lib.
+-- Data.JsonSchema is designed to be imported unqualified.
+-- We're just being explicit here for example purposes.
 
+main :: IO ()
+main = do
+  simpleExample
+  fullExample
+
+--------------------------------------------------
+-- * Example Schema and Data
+--------------------------------------------------
+
 schemaData :: JS.RawSchema
 schemaData = JS.RawSchema
-  { JS._rsURI    = ""
-  , JS._rsObject = schemaJSON
+  { JS._rsURI  = Nothing
+  -- ^ If your schema has relative references to other schemas
+  -- then you'll need to include this.
+  , JS._rsData = schemaJSON
   }
   where
     schemaJSON :: HashMap Text Value
@@ -29,47 +39,65 @@
 badData :: Value
 badData = Array $ V.fromList ["foo", "foo"]
 
-main :: IO ()
-main = do
+--------------------------------------------------
+-- * Simple Example
+--------------------------------------------------
 
+-- | Since our schema contains no references to other schemas,
+-- we can skip the fetchGraph step.
+simpleExample :: IO ()
+simpleExample = do
+  schema <- compileSchema (JS.SchemaGraph schemaData H.empty) schemaData
+  checkResults (JS.validate schema badData)
+
+--------------------------------------------------
+-- * Full Example
+--------------------------------------------------
+
+-- | For a schema that might contain references to other schemas.
+fullExample :: IO ()
+fullExample = do
   let currentSchemaCache = H.empty
-  newSchemaCache <- (<> currentSchemaCache) <$> fetchGraph schemaData
+  schemaGraph <- fetchGraph currentSchemaCache schemaData
 
-  schema <- compileSchema newSchemaCache schemaData
+  -- We aren't going to use it for anything this time, but if we were caching
+  -- remote schemas this would be our new cache.
+  --
+  -- let newSchemaCache = _cachedSchemas schemaData <> currentSchemaGraph
+
+  schema <- compileSchema schemaGraph schemaData
   checkResults (JS.validate schema badData)
 
   where
-
-    -- Not necessary in this case, but it serves as an example.
-    --
-    -- Note that Graphs are used to handle internal as well as external references.
-    -- So even if a schema doesn't reference outside documents, you still need
-    -- to generate a real Graph (and not just use mempty) if it refences itself.
-    fetchGraph :: JS.RawSchema -> IO JS.Graph
-    fetchGraph rs = do
-      eitherGraph <- JS.fetchReferencedSchemas JS.draft4 rs H.empty
+    fetchGraph :: HashMap Text (HashMap Text Value) -> JS.RawSchema -> IO JS.SchemaGraph
+    fetchGraph graph rs = do
+      eitherGraph <- JS.fetchReferencedSchemas JS.draft4 graph rs
       case eitherGraph of
-        Left e      -> error $ "Failed to fetch graph with error: " <> T.unpack e
-        Right graph -> return graph
+        Left e  -> error $ "Failed to fetch graph with error: " <> T.unpack e
+        Right g -> return g
 
-    compileSchema :: JS.Graph -> JS.RawSchema -> IO (JS.Schema JS.Draft4Failure)
-    compileSchema graph rs =
-      case JS.compileDraft4 graph rs of
-        Left failure -> error $ "Not a valid schema: " <> show failure
-        Right schema -> return schema
+--------------------------------------------------
+-- * Helper Functions
+--------------------------------------------------
 
-    checkResults :: [JS.ValidationFailure JS.Draft4Failure] -> IO ()
-    checkResults [] = error "OHNO we validated bad data!"
-    checkResults [JS.ValidationFailure JS.UniqueItems (JS.FailureInfo x y)] =
-      putStrLn . unlines $
-        [ ""
-        , "Success. We got a UniqueItems error as expected."
-        , "Here's the relevant part of the bad JSON document:"
-        , ""
-        , "  " <> show y
-        , ""
-        , "And here's the content of the validator that caught it:"
-        , ""
-        , "  " <> show x
-        ]
-    checkResults x = error $ "OHNO we got a different failure than we expected: " <> show x
+compileSchema :: JS.SchemaGraph -> JS.RawSchema -> IO (JS.Schema JS.Draft4Failure)
+compileSchema graph rs =
+  case JS.compileDraft4 graph rs of
+    Left failure -> error $ "Not a valid schema: " <> show failure
+    Right schema -> return schema
+
+checkResults :: [JS.ValidationFailure JS.Draft4Failure] -> IO ()
+checkResults [] = error "OHNO we validated bad data!"
+checkResults [JS.ValidationFailure JS.UniqueItems (JS.FailureInfo x y)] =
+  putStrLn . unlines $
+    [ ""
+    , "Success. We got a UniqueItems error as expected."
+    , "Here's the relevant part of the bad JSON document:"
+    , ""
+    , "  " <> show y
+    , ""
+    , "And here's the content of the validator that caught it:"
+    , ""
+    , "  " <> show x
+    ]
+checkResults x = error $ "OHNO we got a different failure than we expected: " <> show x
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,27 +1,55 @@
-# Intro
+![hjsonschema logo](./logo.jpg)
 
-An implementation of [JSON Schema](http://json-schema.org/) Draft 4 in haskell.
+A Haskell implementation of the current [JSON Schema](http://json-schema.org/) specification (Draft 4).
 
-# Status
+[Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema)
 
-Still in development. Lacks solid code to handle changing resolution scope.
+# Example
 
-Also note that hjsonschema uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library for the "pattern" validator. This isn't compatible with the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires.
+See [Example.hs on GitHub](https://github.com/seagreen/hjsonschema/blob/master/Example.hs).
 
-# Example
+# Tests
 
-See [Example.hs](./Example.hs).
+## Install
 
-# Install Tests
+`git submodule update --init`
 
-    git submodule update --init
+## Run
 
-# Notes
+Will run self-contained:
 
+`cabal test local`
+
+Will start an HTTP server temporarily on port 1234:
+
+`cabal test remote`
+
+# Details
+
+## Goals
+
++ Be a correct and fast implementation of the spec.
+
++ Be a useful reference for implementers in other languages. Haskell's high level nature, expressive type system and referential transparency suit this purpose well.
+
+## Good Parts
+
++ Passes all the tests in the [language agnostic test suite](https://github.com/json-schema/JSON-Schema-Test-Suite).
+
++ Very modular, which should make it easy to support future versions of the specification.
+
+## Bad Parts
+
++ Uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library for the "pattern" validator. It should use a library based on the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires.
+
+## Notes
+
 + `draft4.json` is from commit # cc8ec81ce0abe2385ebd6c2a6f2d6deb646f874a [here](https://github.com/json-schema/json-schema).
 
-# Credits
+## Credits
 
-Thanks to [Julian Berman](https://github.com/Julian) for the fantastic test suite.
+[TJ Weigel](http://tjweigel.com/) created the logo.
 
-Also thanks to Tim Baumann for his [aeson-schema](https://hackage.haskell.org/package/aeson-schema) library. Hjsonschema's test code and its implementation of `Graph` both originally came from there.
+[Tim Baumann](https://github.com/timjb) wrote [aeson-schema](https://hackage.haskell.org/package/aeson-schema), on which hjsonschema's test code and its implementation of `SchemaGraph` were based.
+
+[Julian Berman](https://github.com/Julian) maintains the fantastic [language agnostic test suite](https://github.com/json-schema/JSON-Schema-Test-Suite).
diff --git a/changelog.txt b/changelog.txt
--- a/changelog.txt
+++ b/changelog.txt
@@ -1,3 +1,14 @@
+# 0.8
+
++ Improve scope updating and resolving.
++ Rename RawSchema's _rsObject field to _rsData.
++ Make RawSchema's _rsURI field a Maybe. This way schemas without a starting
+URI can say so explicitly with Nothing instead of with "".
++ Rename Graph to SchemaGraph. Declare it with data instead of type. Give it a
+field referencing the starting schema. This field is used to find the curent
+schema if no URI is in scope and a self-referencing $ref is found (e.g. "#").
++ Change the order of the last two arguments to fetchReferencedSchemas.
+
 # 0.7.1
 
 + Support GHC 7.8 again.
diff --git a/hjsonschema.cabal b/hjsonschema.cabal
--- a/hjsonschema.cabal
+++ b/hjsonschema.cabal
@@ -1,5 +1,5 @@
 name:                   hjsonschema
-version:                0.7.1.0
+version:                0.8.0.0
 synopsis:               JSON Schema library
 homepage:               https://github.com/seagreen/hjsonschema
 license:                MIT
@@ -35,7 +35,7 @@
                         OverloadedStrings
   other-extensions:     TemplateHaskell
   ghc-options:          -Wall
-  build-depends:        aeson                >= 0.7   && < 0.10
+  build-depends:        aeson                >= 0.7   && < 0.11
                         -- 4.6 doesn't have a Traversable Either instance:
                       , base                 >= 4.7   && < 4.9
                       , bytestring           >= 0.10  && < 0.11
@@ -44,7 +44,7 @@
                       , hashable             >= 1.2   && < 1.3
                       , hjsonpointer         >= 0.2   && < 0.3
                       , http-client          >= 0.4.9 && < 0.5
-                      , http-types           >= 0.8   && < 0.9
+                      , http-types           >= 0.8   && < 0.10
                       , mtl                  >= 2.2.1 && < 2.3
                       , regexpr              >= 0.5   && < 0.6
                       , scientific           >= 0.3   && < 0.4
@@ -53,17 +53,6 @@
                       , text                 >= 1.2   && < 1.3
                       , vector               >= 0.10  && < 0.12
 
-executable example
-  main-is:              Example.hs
-  default-language:     Haskell2010
-  ghc-options:          -Wall
-  build-depends:        aeson
-                      , base
-                      , hjsonschema
-                      , text
-                      , unordered-containers
-                      , vector
-
 test-suite local
   type:                 exitcode-stdio-1.0
   hs-source-dirs:       tests
@@ -76,7 +65,6 @@
                       , base
                       , bytestring
                       , hjsonschema
-                      , unordered-containers
                       , text
                       , vector
                       , directory            >= 1.2 && < 1.3
@@ -98,16 +86,26 @@
                       , base
                       , bytestring
                       , hjsonschema
-                      , unordered-containers
                       , text
                       , vector
-                      , directory            >= 1.2 && < 1.3
-                      , filepath             >= 1.3 && < 1.4
-                      , HUnit                >= 1.2 && < 1.3
-                      , test-framework       >= 0.8 && < 0.9
-                      , test-framework-hunit >= 0.3 && < 0.4
+                      , directory
+                      , filepath
+                      , HUnit
+                      , test-framework
+                      , test-framework-hunit
                       , wai-app-static
                       , warp
+
+executable example
+  main-is:              Example.hs
+  default-language:     Haskell2010
+  ghc-options:          -Wall
+  build-depends:        aeson
+                      , base
+                      , hjsonschema
+                      , text
+                      , unordered-containers
+                      , vector
 
 source-repository head
   type:               git
diff --git a/src/Data/JsonSchema.hs b/src/Data/JsonSchema.hs
--- a/src/Data/JsonSchema.hs
+++ b/src/Data/JsonSchema.hs
@@ -8,14 +8,11 @@
   , module Data.JsonSchema.Draft4
   ) where
 
-
 import           Control.Monad.Except (MonadError, MonadIO, join, throwError)
 import qualified Data.ByteString.Lazy as LBS
 import           Data.Foldable
 import qualified Data.HashMap.Strict as H
 import           Data.String
-import qualified Data.Text as T
-import qualified Data.Vector as V
 
 import           Data.JsonSchema.Core
 import           Data.JsonSchema.Draft4
@@ -24,57 +21,66 @@
 import           Import
 
 -- For GHCs before 7.10:
-import           Prelude hiding (sequence)
+import           Prelude hiding (concat, sequence)
 
 -- | Take a schema. Retrieve every document either it or its
--- subschemas include via the "$ref" keyword. Load a 'Graph' out
+-- subschemas include via the "$ref" keyword. Load a 'SchemaGraph' out
 -- with them.
---
--- TODO: This function's URL processing is hacky and needs improvement.
-fetchReferencedSchemas :: Spec err -> RawSchema -> Graph -> IO (Either Text Graph)
+fetchReferencedSchemas :: Spec err -> SchemaCache -> RawSchema -> IO (Either Text SchemaGraph)
 fetchReferencedSchemas = fetchReferencedSchemas' HE.defaultFetch
 
 -- | A version of fetchReferencedSchemas where the function to make requests
 -- is provided by the user. This allows restrictions to be added, e.g. rejecting
--- non-local URLs.
+-- non-local URIs.
 fetchReferencedSchemas'
   -- The `Functor m` declaration is for GHCs before 7.10.
   :: forall m e t err. (MonadIO m, Functor m, MonadError t e, Traversable e, IsString t)
   => (Text -> m (e LBS.ByteString))
   -> Spec err
+  -> SchemaCache
   -> RawSchema
-  -> Graph
-  -> m (e Graph)
-fetchReferencedSchemas' fetchRef spec rawSchema graph =
-  let startingGraph = H.insert (_rsURI rawSchema) (_rsObject rawSchema) graph
-  in foldlM (modFetch fetch) (return startingGraph) (includeSubschemas rawSchema)
+  -> m (e SchemaGraph)
+fetchReferencedSchemas' fetchRef spec cache rawSchema = do
+  let startingCache = case _rsURI rawSchema of
+                        Nothing  -> cache
+                        Just uri -> H.insert uri (_rsData rawSchema) cache
+  fmap (SchemaGraph rawSchema) <$> foldlM fetch (return startingCache) (includeSubschemas rawSchema)
 
   where
-    includeSubschemas :: RawSchema -> Vector RawSchema
+    -- TODO: use a fold here
+    includeSubschemas :: RawSchema -> [RawSchema]
     includeSubschemas r =
-      let newId = newResolutionScope (_rsURI r) (_rsObject r)
-          xs = H.intersectionWith (\(ValSpec f _) x -> f newId x) (_unSpec spec) (_rsObject r)
-          ys = V.concat . H.elems $ xs -- TODO: optimize
-      in V.cons r . V.concat . V.toList $ includeSubschemas <$> ys
-
-    modFetch :: (Graph -> RawSchema -> m (e Graph)) -> e Graph -> RawSchema -> m (e Graph)
-    modFetch f eg rs = join <$> sequence (flip f rs <$> eg)
+      let scope = _rsURI r `newResolutionScope` _rsData r
+          xs = H.intersectionWith (\(ValSpec f _) x -> f scope x) (_unSpec spec) (_rsData r)
+      in r : (concat . concat . H.elems $ fmap includeSubschemas <$> xs)
 
-    fetch :: Graph -> RawSchema -> m (e Graph)
-    fetch g r =
-      case H.lookup "$ref" (_rsObject r) >>= HE.toTxt >>= refAndPointer of
-        Nothing     -> return (return g)
-        Just (s, _) ->
-          let url = (_rsURI r `combineIdAndRef` s)
-          in if T.length url <= 0 || H.member url g || not ("://" `T.isInfixOf` url)
-            then return (return g)
-            else modDec (decodeResponse url) =<< fetchRef url
+    fetch :: e SchemaCache -> RawSchema -> m (e SchemaCache)
+    fetch eg r = join <$> sequence (run <$> eg)
       where
-        decodeResponse :: Text -> LBS.ByteString -> m (e Graph)
-        decodeResponse url bts =
+        run :: SchemaCache -> m (e SchemaCache)
+        run g = do
+          -- Resolving the new scope is necessary here because of situations like this:
+          --
+          -- {
+          --     "id": "http://localhost:1234/",
+          --     "items": {
+          --         "id": "folder/",
+          --         "items": {"$ref": "folderInteger.json"}
+          --     }
+          -- }
+          let scope = newResolutionScope (_rsURI r) (_rsData r)
+          case resolveReference scope <$> (H.lookup "$ref" (_rsData r) >>= HE.toTxt) of
+            Just (Just uri,_) ->
+              if not (isRemoteReference uri) || H.member uri g
+                then return (return g)
+                else fetchRef uri >>= decodeResponse g uri
+            _ -> return (return g)
+
+        decodeResponse :: SchemaCache -> Text -> e LBS.ByteString -> m (e SchemaCache)
+        decodeResponse g uri eBts = join <$> sequence (runDecode g uri <$> eBts)
+
+        runDecode :: SchemaCache -> Text -> LBS.ByteString -> m (e SchemaCache)
+        runDecode g uri bts =
           case eitherDecode bts of
             Left e    -> return $ throwError (fromString e)
-            Right obj -> fetchReferencedSchemas' fetchRef spec (RawSchema url obj) g
-
-        modDec :: (LBS.ByteString -> m (e Graph)) -> e LBS.ByteString -> m (e Graph)
-        modDec f eBts = join <$> sequence (f <$> eBts)
+            Right obj -> fmap _cachedSchemas <$> fetchReferencedSchemas' fetchRef spec g (RawSchema (Just uri) obj)
diff --git a/src/Data/JsonSchema/Core.hs b/src/Data/JsonSchema/Core.hs
--- a/src/Data/JsonSchema/Core.hs
+++ b/src/Data/JsonSchema/Core.hs
@@ -15,7 +15,7 @@
 -- * Primary API
 --------------------------------------------------
 
-compile :: forall err. Spec err -> Graph -> RawSchema -> Schema err
+compile :: forall err. Spec err -> SchemaGraph -> RawSchema -> Schema err
 compile spec g (RawSchema t o) =
   let maybeValidators = H.intersectionWith f (_unSpec spec) o
   in Schema . catMaybes . H.elems $ maybeValidators
@@ -35,15 +35,22 @@
 newtype Schema err = Schema { _unSchema :: [Value -> [ValidationFailure err]] }
 
 data RawSchema = RawSchema
-  { _rsURI    :: Text
-  , _rsObject :: HashMap Text Value
-  }
+  { _rsURI  :: !(Maybe Text)
+  -- ^ NOTE: Must not include a URI fragment.
+  , _rsData :: !(HashMap Text Value)
+  } deriving (Show)
 
--- | A mapping of URLs to schemas.
+-- | A set of RawSchemas, split into a HashMap.
 --
--- Each key/value pair provides the components of a RawSchema.
-type Graph = HashMap Text (HashMap Text Value)
+-- Keys correspond to Schema _rsURIs. Values correspond to Schema _rsObjects.
+type SchemaCache = HashMap Text (HashMap Text Value)
 
+data SchemaGraph = SchemaGraph
+  { _startingSchema :: !RawSchema
+  -- ^ The schema initially referenced by '#'.
+  , _cachedSchemas  :: !SchemaCache
+  } deriving (Show)
+
 --------------------------------------------------
 -- * Validators
 --------------------------------------------------
@@ -55,7 +62,7 @@
 -- This is used by 'Data.JsonSchema.fetchRefs' to find all the
 -- subschemas in a document. This allows it to process only
 -- "$ref"s and "id"s that are actual schema keywords.
-type EmbeddedSchemas = Text -> Value -> Vector RawSchema
+type EmbeddedSchemas = Maybe Text -> Value -> [RawSchema]
 
 -- | This is what's used to write most validators in practice.
 --
@@ -68,17 +75,17 @@
 -- and modifyName for this purpose.
 type ValidatorConstructor schemaErr valErr
    = Spec schemaErr
-  -> Graph
+  -> SchemaGraph
   -> RawSchema
   -> Value
   -> Maybe (Value -> valErr)
 
 data ValidationFailure err = ValidationFailure
-  { _failureName :: err
-  , _failureInfo :: FailureInfo
+  { _failureName :: !err
+  , _failureInfo :: !FailureInfo
   } deriving (Show)
 
 data FailureInfo = FailureInfo
-  { _validatingData :: Value
-  , _offendingData  :: Value
+  { _validatingData :: !Value
+  , _offendingData  :: !Value
   } deriving (Show)
diff --git a/src/Data/JsonSchema/Draft4.hs b/src/Data/JsonSchema/Draft4.hs
--- a/src/Data/JsonSchema/Draft4.hs
+++ b/src/Data/JsonSchema/Draft4.hs
@@ -123,7 +123,9 @@
 isValidSchema r =
   case decode . LBS.fromStrict $ $(embedFile "draft4.json") of
     Nothing -> error "Schema decode failed (this should never happen)"
-    Just s  -> validate (compile draft4 H.empty $ RawSchema "" s) $ Object (_rsObject r)
+    Just s  ->
+      let a = RawSchema Nothing s
+      in validate (compile draft4 (SchemaGraph a mempty) a) $ Object (_rsData r)
 
 -- | Check that a 'RawSchema' conforms to the JSON Schema Draft 4
 -- master schema document. Compile it if it does.
@@ -133,7 +135,7 @@
 --
 -- NOTE: It's not actually required to run 'isValidSchema' on
 -- prospective draft 4 schemas at all.
-compileDraft4 :: Graph -> RawSchema -> Either [ValidationFailure Draft4Failure] (Schema Draft4Failure)
+compileDraft4 :: SchemaGraph -> RawSchema -> Either [ValidationFailure Draft4Failure] (Schema Draft4Failure)
 compileDraft4 g r =
   case isValidSchema r of
     []   -> Right (compile draft4 g r)
diff --git a/src/Data/JsonSchema/Draft4/Any.hs b/src/Data/JsonSchema/Draft4/Any.hs
--- a/src/Data/JsonSchema/Draft4/Any.hs
+++ b/src/Data/JsonSchema/Draft4/Any.hs
@@ -3,11 +3,9 @@
 
 import           Control.Monad
 import qualified Data.HashMap.Strict       as H
-import           Data.JsonPointer
+import           Data.Maybe
 import           Data.Scientific
-import           Data.Text.Encoding
 import qualified Data.Vector               as V
-import           Network.HTTP.Types.URI
 
 import           Data.JsonSchema.Core
 import           Data.JsonSchema.Helpers
@@ -93,26 +91,25 @@
 
 notValidator :: ValidatorConstructor err [FailureInfo]
 notValidator spec g s val@(Object o) = do
-  let sub = compile spec g (RawSchema (_rsURI s) o)
+  let subSchema = compile spec g $ RawSchema (_rsURI s) o
   Just $ \x ->
-    case validate sub x of
+    case validate subSchema x of
       [] -> pure (FailureInfo val x)
       _  -> mempty
 notValidator _ _ _ _ = Nothing
 
--- http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03
+-- JSON Reference Draft Document:
 --
--- TODO: Any members other than "$ref" in a JSON Reference object SHALL be
--- ignored.
+--      http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03
 ref :: ValidatorConstructor err [ValidationFailure err]
 ref spec g s (String val) = do
-  (reference, pointer) <- refAndPointer (_rsURI s `combineIdAndRef` val)
-  r <- RawSchema reference <$> H.lookup reference g
-  let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer
-  p <- eitherToMaybe $ jsonPointer urlDecoded
-  case resolvePointer p (Object $ _rsObject r) of
-    Right (Object o) ->
-      let compiled = compile spec g $ RawSchema (_rsURI r) o
-      in Just $ validate compiled
-    _ -> Nothing
+  let (mUri, mFragment) = resolveReference (_rsURI s) val
+  r <- RawSchema mUri <$> getReference mUri
+  let o = resolveFragment mFragment (_rsData r)
+  return . validate . compile spec g $ RawSchema (_rsURI r) o
+  where
+    getReference :: Maybe Text -> Maybe (HashMap Text Value)
+    getReference Nothing  = Just . _rsData . _startingSchema $ g
+    getReference (Just t) = H.lookup t (_cachedSchemas g)
+
 ref _ _ _ _ = Nothing
diff --git a/src/Data/JsonSchema/Draft4/Arrays.hs b/src/Data/JsonSchema/Draft4/Arrays.hs
--- a/src/Data/JsonSchema/Draft4/Arrays.hs
+++ b/src/Data/JsonSchema/Draft4/Arrays.hs
@@ -9,8 +9,15 @@
 import           Data.JsonSchema.Helpers
 import           Import
 
-data ItemsFailure err = Items err | AdditionalItemsBool | AdditionalItemsObject err
+data ItemsFailure err
+  = Items err
+  | AdditionalItemsBool
+  | AdditionalItemsObject err
 
+data AdditionalItemsFailure err
+  = AdditionalBool
+  | AdditionalObject err
+
 -- | A combination of items and additionalItems.
 items :: ValidatorConstructor err [ValidationFailure (ItemsFailure err)]
 items spec g s (Object o) =
@@ -22,36 +29,38 @@
 items spec g s (Array vs) = do
   os <- traverse toObj vs
   let subSchemas = compile spec g . RawSchema (_rsURI s) <$> V.toList os
-      mAdditionalItems = additionalItems spec g s =<< H.lookup "additionalItems" (_rsObject s)
+      mAdditionalItems = additionalItems spec g s =<< H.lookup "additionalItems" (_rsData s)
   Just $ \x ->
     case x of
       Array ys ->
         let extras = V.drop (V.length os) ys
             itemFailures = join $ fmap (modifyFailureName Items) <$> zipWith validate subSchemas (V.toList ys)
             additionalItemFailures = runMaybeVal mAdditionalItems (Array extras)
-        in itemFailures <> additionalItemFailures
+        in itemFailures <> fmap (modifyFailureName f) additionalItemFailures
       _ -> mempty
+  where
+    f :: AdditionalItemsFailure err -> ItemsFailure err
+    f AdditionalBool         = AdditionalItemsBool
+    f (AdditionalObject err) = AdditionalItemsObject err
 items _ _ _ _ = Nothing
 
 -- | Not included directly in the 'draft4' spec hashmap because it always
 -- validates data unless 'items' is also present. This is because 'items'
 -- defaults to {}.
---
--- TODO: Should have its own error type instead of sharing with Items.
-additionalItems :: ValidatorConstructor err [ValidationFailure (ItemsFailure err)]
+additionalItems :: ValidatorConstructor err [ValidationFailure (AdditionalItemsFailure err)]
 additionalItems _ _ _ val@(Bool v) =
   Just $ \x ->
     case x of
       Array ys ->
         if not v && V.length ys > 0
-          then pure $ ValidationFailure AdditionalItemsBool (FailureInfo val x)
+          then pure $ ValidationFailure AdditionalBool (FailureInfo val x)
           else mempty
       _ -> mempty
 additionalItems spec g s (Object o) =
   let subSchema = compile spec g (RawSchema (_rsURI s) o)
   in Just $ \x ->
     case x of
-      Array ys -> V.toList ys >>= fmap (modifyFailureName AdditionalItemsObject) . validate subSchema
+      Array ys -> V.toList ys >>= fmap (modifyFailureName AdditionalObject) . validate subSchema
       _        -> mempty
 additionalItems _ _ _ _ = Nothing
 
diff --git a/src/Data/JsonSchema/Draft4/Numbers.hs b/src/Data/JsonSchema/Draft4/Numbers.hs
--- a/src/Data/JsonSchema/Draft4/Numbers.hs
+++ b/src/Data/JsonSchema/Draft4/Numbers.hs
@@ -37,7 +37,7 @@
   where
     checkExclusive :: (Scientific -> Scientific -> Bool, MaximumFailure)
     checkExclusive =
-      case H.lookup "exclusiveMaximum" (_rsObject s) of
+      case H.lookup "exclusiveMaximum" (_rsData s) of
         Just (Bool a) -> if a then ((>=), ExclusiveMaximum) else ((>), Maximum)
         _             -> ((>), Maximum)
 maximumVal _ _ _ _ = Nothing
@@ -55,7 +55,7 @@
   where
     checkExclusive :: (Scientific -> Scientific -> Bool, MinimumFailure)
     checkExclusive =
-      case H.lookup "exclusiveMinimum" (_rsObject s) of
+      case H.lookup "exclusiveMinimum" (_rsData s) of
         Just (Bool a) -> if a then ((<=), ExclusiveMinimum) else ((<), Minimum)
         _             -> ((<), Minimum)
 minimumVal _ _ _ _ = Nothing
diff --git a/src/Data/JsonSchema/Draft4/Objects.hs b/src/Data/JsonSchema/Draft4/Objects.hs
--- a/src/Data/JsonSchema/Draft4/Objects.hs
+++ b/src/Data/JsonSchema/Draft4/Objects.hs
@@ -85,7 +85,7 @@
         in schemaFailures <> propertyFailures
       _ -> mempty
   where
-    toSchemaDep :: Spec a -> Graph -> (Text, Value) -> [(Text, Schema a)]
+    toSchemaDep :: Spec a -> SchemaGraph -> (Text, Value) -> [(Text, Schema a)]
     toSchemaDep spc gr (t, Object ob) = pure (t, compile spc gr $ RawSchema (_rsURI s) ob)
     toSchemaDep _ _ _ = mempty
 
diff --git a/src/Data/JsonSchema/Draft4/Objects/Properties.hs b/src/Data/JsonSchema/Draft4/Objects/Properties.hs
--- a/src/Data/JsonSchema/Draft4/Objects/Properties.hs
+++ b/src/Data/JsonSchema/Draft4/Objects/Properties.hs
@@ -30,8 +30,8 @@
 properties :: forall err. ValidatorConstructor err [ValidationFailure (PropertiesFailure err)]
 properties spec g s val = do
   let mProps   = propertiesUnmatched val
-      mPatProp = patternUnmatched spec g s =<< H.lookup "patternProperties" (_rsObject s)
-      mAddProp = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsObject s)
+      mPatProp = patternUnmatched spec g s =<< H.lookup "patternProperties" (_rsData s)
+      mAddProp = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsData s)
   when (isNothing mProps && isNothing mPatProp && isNothing mAddProp) Nothing
   Just $ \x ->
     case x of
@@ -61,12 +61,9 @@
 
 patternProperties :: ValidatorConstructor err [ValidationFailure (PatternPropertiesFailure err)]
 patternProperties spec g s val = do
-  when (H.member "properties" (_rsObject s)) Nothing
+  when (H.member "properties" (_rsData s)) Nothing
   let mPatternProps = patternUnmatched spec g s val
-  -- TODO: checking additionalProperties as well doesn't help with tests.
-  -- Make sure we're doing the correct thing, then get tests for this
-  -- merged into the test suite.
-  let mAdditionalProps = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsObject s)
+  let mAdditionalProps = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsData s)
   when (isNothing mPatternProps && isNothing mAdditionalProps) Nothing
   Just $ \x ->
     case x of
@@ -78,7 +75,7 @@
 
 patternUnmatched
   :: Spec err
-  -> Graph
+  -> SchemaGraph
   -> RawSchema
   -> Value
   -> Maybe (Value -> ([ValidationFailure err], Value))
@@ -122,8 +119,8 @@
 
 additionalProperties :: ValidatorConstructor err [ValidationFailure (AdditionalPropertiesFailure err)]
 additionalProperties spec g s val = do
-  when (H.member "properties" (_rsObject s)) Nothing
-  when (H.member "patternProperties" (_rsObject s)) Nothing
+  when (H.member "properties" (_rsData s)) Nothing
+  when (H.member "patternProperties" (_rsData s)) Nothing
   runAdditionalProperties spec g s val
 
 -- | An additionalProperties validator than never disables itself.
diff --git a/src/Data/JsonSchema/Helpers.hs b/src/Data/JsonSchema/Helpers.hs
--- a/src/Data/JsonSchema/Helpers.hs
+++ b/src/Data/JsonSchema/Helpers.hs
@@ -1,3 +1,4 @@
+
 module Data.JsonSchema.Helpers where
 
 import           Control.Exception
@@ -24,7 +25,7 @@
 objEmbed _ _ = mempty
 
 arrayEmbed :: EmbeddedSchemas
-arrayEmbed t (Array vs) = objEmbed t =<< vs
+arrayEmbed t (Array vs) = objEmbed t =<< V.toList vs
 arrayEmbed _ _ = mempty
 
 objOrArrayEmbed :: EmbeddedSchemas
@@ -33,28 +34,27 @@
 objOrArrayEmbed _ _ = mempty
 
 objMembersEmbed :: EmbeddedSchemas
-objMembersEmbed t (Object o) = objEmbed t =<< V.fromList (H.elems o)
+objMembersEmbed t (Object o) = objEmbed t =<< H.elems o
 objMembersEmbed _ _ = mempty
 
 --------------------------------------------------
 -- * Modify Validators for use in Specs
 --------------------------------------------------
 
--- | TODO: Is there something easier to replace these fmaps with?
 giveName
   :: forall err. err
   -> ValidatorConstructor err [FailureInfo]
   -> ValidatorConstructor err [ValidationFailure err]
-giveName err = (fmap.fmap.fmap.fmap.fmap.fmap.fmap) (ValidationFailure err)
+giveName err f spec g rs v = (fmap.fmap) (ValidationFailure err) <$> f spec g rs v
 
 modifyName
   :: forall valErr schemaErr. (valErr -> schemaErr)
   -> ValidatorConstructor schemaErr [ValidationFailure valErr]
   -> ValidatorConstructor schemaErr [ValidationFailure schemaErr]
-modifyName failureHandler = (fmap.fmap.fmap.fmap.fmap.fmap.fmap) f
+modifyName failureHandler f spec g rs v = (fmap.fmap) modErr <$> f spec g rs v
   where
-    f :: ValidationFailure valErr -> ValidationFailure schemaErr
-    f (ValidationFailure a b) = ValidationFailure (failureHandler a) b
+    modErr :: ValidationFailure valErr -> ValidationFailure schemaErr
+    modErr (ValidationFailure a b) = ValidationFailure (failureHandler a) b
 
 -- | It's important to know if an object's a validator (even if it will never run,
 -- like the definitions validator) because parts of it might be referenced by other
diff --git a/src/Data/JsonSchema/Reference.hs b/src/Data/JsonSchema/Reference.hs
--- a/src/Data/JsonSchema/Reference.hs
+++ b/src/Data/JsonSchema/Reference.hs
@@ -1,39 +1,65 @@
--- | TODO: The code handling resolution scope updates
--- is hacky and needs improvement.
 
 module Data.JsonSchema.Reference where
 
-import qualified Data.HashMap.Strict as H
-import qualified Data.Text           as T
+import qualified Data.HashMap.Strict    as H
+import           Data.JsonPointer
+import qualified Data.Text              as T
+import           Data.Text.Encoding
+import           Network.HTTP.Types.URI
 
 import           Import
 
-combineIdAndRef :: Text -> Text -> Text
-combineIdAndRef a b
-  | "://" `T.isInfixOf` b              = b
-  | T.length a < 1 || T.length b < 1   = a <> b
-  | T.last a == '#' && T.head b == '#' = a <> T.tail b
-  | otherwise                          = a <> b
-
-combineIds :: Text -> Text -> Text
-combineIds a b
-  | b == "#" || b == ""                = a
-  | "://" `T.isInfixOf` b              = b
-  | T.length a < 1 || T.length b < 1   = a <> b
-  | T.last a == '#' && T.head b == '#' = a <> T.tail b
-  | otherwise                          = a <> b
+type URIBase = Maybe Text
+type URIBaseAndFragment = (Maybe Text, Maybe Text)
 
-newResolutionScope :: Text -> HashMap Text Value -> Text
-newResolutionScope t o =
+newResolutionScope :: URIBase -> HashMap Text Value -> URIBase
+newResolutionScope mScope o =
   case H.lookup "id" o of
-    Just (String idKeyword) -> t `combineIds` idKeyword
-    _                       -> t
+    Just (String t) -> fst . baseAndFragment $ resolveScopeAgainst mScope t
+    _               -> mScope
 
-refAndPointer :: Text -> Maybe (Text, Text)
-refAndPointer val = getParts $ T.splitOn "#" val
+resolveReference :: URIBase -> Text -> URIBaseAndFragment
+resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t
+
+isRemoteReference :: Text -> Bool
+isRemoteReference uri = "://" `T.isInfixOf` uri
+
+resolveFragment :: Maybe Text -> HashMap Text Value -> HashMap Text Value
+resolveFragment Nothing hm        = hm
+resolveFragment (Just pointer) hm =
+  let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer
+  in case jsonPointer urlDecoded of
+    Left _  -> hm
+    Right p ->
+      case resolvePointer p (Object hm) of
+        Right (Object hm') -> hm'
+        _                  -> hm
+
+--------------------------------------------------
+-- * Internal
+--------------------------------------------------
+
+baseAndFragment :: Text -> URIBaseAndFragment
+baseAndFragment = f . T.splitOn "#"
   where
-    getParts :: [Text] -> Maybe (Text, Text)
-    getParts []    = Just ("","")
-    getParts [x]   = Just (x,"")
-    getParts [x,y] = Just (x,y)
-    getParts _     = Nothing
+    f :: [Text] -> URIBaseAndFragment
+    f [x]   = (g x, Nothing)
+    f [x,y] = (g x, g y)
+    f _     = (Nothing, Nothing)
+
+    g "" = Nothing
+    g x  = Just x
+
+resolveScopeAgainst :: Maybe Text -> Text -> Text
+resolveScopeAgainst Nothing t = t
+resolveScopeAgainst (Just scope) t
+  | isRemoteReference t = t
+  | otherwise           = smartAppend
+  where
+    -- There shouldn't be a fragment at the end of a scope URI,
+    -- but just in case a user leaves one in we want to be sure
+    -- to cut it off before appending.
+    smartAppend :: Text
+    smartAppend = case baseAndFragment scope of
+                    (Just base,_) -> base <> t
+                    _             -> t
diff --git a/tests/Lib.hs b/tests/Lib.hs
--- a/tests/Lib.hs
+++ b/tests/Lib.hs
@@ -9,7 +9,6 @@
 import           Data.Aeson.TH
 import qualified Data.ByteString.Lazy           as LBS
 import           Data.Char                      (toLower)
-import qualified Data.HashMap.Strict            as H
 import           Data.JsonSchema
 import           Data.Monoid
 import           Data.Text                      (Text)
@@ -37,8 +36,7 @@
   }
 
 instance FromJSON RawSchema where
-  parseJSON = withObject "Schema" $ \o ->
-    return RawSchema { _rsURI = "", _rsObject = o }
+  parseJSON = withObject "Schema" $ return . RawSchema Nothing
 
 instance FromJSON SchemaTest where
   parseJSON = withObject "SchemaTest" $ \o -> SchemaTest
@@ -71,7 +69,7 @@
   testCase (T.unpack $ _stDescription st) $ do
     sanityCheckTest (_stSchema st)
     forM_ (_stCases st) $ \sc -> do
-      g <- assertRight =<< fetchReferencedSchemas draft4 (_stSchema st) H.empty
+      g <- assertRight =<< fetchReferencedSchemas draft4 mempty (_stSchema st)
       let res = validate (compile draft4 g $ _stSchema st) (_scData sc)
       if _scValid sc
         then assertValid   sc res