0.3.0.0 - rewrite.

.travis.yml

@@ -0,0 +1,81 @@
+# This file has been generated -- see https://github.com/hvr/multi-ghc-travis
+#
+# Manually modified to remove cabal check. I don't want a description field.
+
+language: c
+sudo: false
+
+cache:
+  directories:
+    - $HOME/.cabsnap
+    - $HOME/.cabal/packages
+
+before_cache:
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
+
+matrix:
+  include:
+    - env: CABALVER=1.18 GHCVER=7.8.4
+      compiler: ": #GHC 7.8.4"
+      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
+    - env: CABALVER=1.22 GHCVER=7.10.2
+      compiler: ": #GHC 7.10.2"
+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}
+
+before_install:
+ - unset CC
+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
+
+install:
+ - cabal --version
+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
+   then
+     zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
+          $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
+   fi
+ - travis_retry cabal update -v
+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
+ - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
+ - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
+
+# check whether current requested install-plan matches cached package-db snapshot
+ - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
+   then
+     echo "cabal build-cache HIT";
+     rm -rfv .ghc;
+     cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
+     cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
+   else
+     echo "cabal build-cache MISS";
+     rm -rf $HOME/.cabsnap;
+     mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
+     cabal install --only-dependencies --enable-tests --enable-benchmarks;
+   fi
+ 
+# snapshot package-db on cache miss
+ - if [ ! -d $HOME/.cabsnap ];
+   then
+      echo "snapshotting package-db to build-cache";
+      mkdir $HOME/.cabsnap;
+      cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
+      cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
+   fi
+
+# Here starts the actual work to be performed for the package under test;
+# any command which exits with a non-zero exit code causes the build to fail.
+script:
+ - if [ -f configure.ac ]; then autoreconf -i; fi
+ - cabal configure --enable-tests --enable-benchmarks -v2  # -v2 provides useful information for debugging
+ - cabal build   # this builds all libraries and executables (including tests/benchmarks)
+ - cabal test
+ - cabal sdist   # tests that a source-distribution can be generated
+
+# Check that the resulting source distribution can be built & installed.
+# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
+# `cabal install --force-reinstalls dist/*-*.tar.gz`
+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
+   (cd dist && cabal install --force-reinstalls "$SRC_TGZ")
+
+# EOF

Example.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import           Control.Monad      (unless)
+import           Data.Aeson
+import qualified Data.Aeson.Pointer as P
+
+main :: IO ()
+main = do
+  -- JSON Pointers must either be empty or start with a /.
+  pntr1 <- case P.unescape "/foo/0" of
+             Left _     -> error "Failed to construct JSON Pointer."
+             Right pntr -> return pntr
+
+  -- We can also write JSON Pointers in Haskell.
+  let pntr2 = P.Pointer [P.Token "/"]
+  -- When we do this we don't have to escape / or ~ characters
+  -- (as ~1 and ~0 respectively) like we do in an escaped JSON
+  -- Pointer string.
+  unless (P.unescape "/~1" == Right pntr2) (error "ohno!")
+
+  print (P.resolve pntr1 document)
+  print (P.resolve pntr2 document)
+
+  where
+    document :: Value
+    document = object [ "foo" .= [String "bar", String "baz"]
+                      , "/"   .= String "quux"
+                      ]

README.md

@@ -2,28 +2,45 @@
 
 [JSON Pointer](http://tools.ietf.org/html/rfc6901) library for Haskell.
 
+[Hackage](https://hackage.haskell.org/package/hjsonpointer) / [GitHub](https://github.com/seagreen/hjsonpointer) / [Travis CI](https://travis-ci.org/seagreen/hjsonpointer)
+
 # Example
 
-```
+```haskell
 {-# LANGUAGE OverloadedStrings #-}
 
 module Main where
 
+import           Control.Monad      (unless)
 import           Data.Aeson
-import qualified Data.HashMap.Strict as H
-import           Data.JsonPointer
+import qualified Data.Aeson.Pointer as P
 
 main :: IO ()
-main =
-  case jsonPointer "/foo" of
-    Left e     -> print e
-    Right pntr ->
-      case resolvePointer pntr (Object $ H.singleton "foo" $ String "bar") of
-        Left e2 -> print e2
-        Right v -> print v
+main = do
+  -- JSON Pointers must either be empty or start with a /.
+  pntr1 <- case P.unescape "/foo/0" of
+             Left _     -> error "Failed to construct JSON Pointer."
+             Right pntr -> pure pntr
+
+  -- We can also write JSON Pointers in Haskell.
+  let pntr2 = P.Pointer [P.Token "/"]
+  -- When we do this we don't have to escape / or ~ characters
+  -- (as ~1 and ~0 respectively) like we do in an escaped JSON
+  -- Pointer string.
+  unless (P.unescape "/~1" == Right pntr2) (error "ohno!")
+
+  print (P.resolve pntr1 document)
+  print (P.resolve pntr2 document)
+
+  where
+    document :: Value
+    document = object [ "foo" .= [String "bar", String "baz"]
+                      , "/"   .= String "quux"
+                      ]
 ```
 
 Output:
 ```
-String "bar"
+Right (String "bar")
+Right (String "quux")
 ```

changelog.md

@@ -0,0 +1,13 @@
+# 0.3
+
++ Rewrite.
+
+# 0.2
+
++ Fix mistake in `resolveRefTok`.
++ Split errors over two types.
++ Switch the order of pointer and value arguments for functions that take both. The pointer now comes first.
+
+# 0.1
+
++ Initial implementation.

changelog.txt

@@ -1,9 +0,0 @@
-# 0.2
-
-Fix mistake in resolveRefTok.
-Split errors over two types.
-Switch the order of pointer and value arguments for functions that take both. The pointer now comes first.
-
-# 0.1
-
-Initial implementation.

hjsonpointer.cabal

@@ -1,5 +1,5 @@
 name:                   hjsonpointer
-version:                0.2.0.4
+version:                0.3.0.0
 synopsis:               JSON Pointer library
 homepage:               https://github.com/seagreen/hjsonpointer
 license:                MIT
@@ -9,17 +9,20 @@ maintainer:             ian@housejeffries.com
 category:               Data
 build-type:             Simple
 cabal-version:          >=1.10
-extra-source-files:     changelog.txt
+tested-with:            GHC == 7.8.4, GHC == 7.10.3
+extra-source-files:     changelog.md
                         README.md
 
 library
   hs-source-dirs:       src
-  exposed-modules:      Data.JsonPointer
+  exposed-modules:      Data.Aeson.Pointer
   default-language:     Haskell2010
   default-extensions:   OverloadedStrings
+  other-extensions:     GeneralizedNewtypeDeriving
   ghc-options:          -Wall
-  build-depends:        aeson                >= 0.7  && < 0.10
+  build-depends:        aeson                >= 0.7  && < 0.12
                       , base                 >= 4.6  && < 4.9
+                      , QuickCheck           >= 2.8  && < 2.9
                       , unordered-containers >= 0.2  && < 0.3
                       , text                 >= 1.2  && < 1.3
                       , vector               >= 0.10 && < 0.12
@@ -37,10 +40,19 @@ test-suite unit
                       , unordered-containers
                       , text
                       , vector
-                      , http-types           >= 0.8 && < 0.9
-                      , HUnit                >= 1.2 && < 1.4
-                      , test-framework       >= 0.8 && < 0.9
-                      , test-framework-hunit >= 0.3 && < 0.4
+                      , http-types                 >= 0.8 && < 0.10
+                      , HUnit                      >= 1.2 && < 1.4
+                      , test-framework             >= 0.8 && < 0.9
+                      , test-framework-hunit       >= 0.3 && < 0.4
+                      , test-framework-quickcheck2 >= 0.3 && < 0.4
+
+executable example
+  main-is:              Example.hs
+  default-language:     Haskell2010
+  ghc-options:          -Wall
+  build-depends:        aeson
+                      , base
+                      , hjsonpointer
 
 source-repository head
   type:               git

src/Data/Aeson/Pointer.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Data.Aeson.Pointer where
+
+import           Control.Monad       (when)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as H
+import           Data.Text           (Text)
+import qualified Data.Text           as T
+import qualified Data.Vector         as V
+import           Test.QuickCheck
+import           Text.Read           (readMaybe)
+
+-- For GHCs before 7.10:
+import           Control.Applicative
+import           Data.Monoid
+import           Data.Traversable
+
+newtype Pointer
+  = Pointer { _unPointer :: [Token] }
+  deriving (Eq, Show, Monoid, Arbitrary)
+
+instance FromJSON Pointer where
+  parseJSON = withText "JSON Pointer" $ \t ->
+    case unescape t of
+      Left e  -> fail (show e)
+      Right p -> pure p
+
+instance ToJSON Pointer where
+  toJSON = String . escape
+
+-- | We don't try to distinguish between integer tokens and string
+-- tokens since all tokens start as strings, and all tokens can
+-- be used to resolve JSON objects.
+newtype Token = Token { _unToken :: Text } deriving (Eq, Show)
+
+instance Arbitrary Token where
+  arbitrary = Token . T.pack <$> arbitrary
+
+escape :: Pointer -> Text
+escape (Pointer []) = ""
+escape (Pointer ts) =
+    T.cons '/'
+  . T.intercalate "/"
+  . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken)
+  $ ts
+
+-- * Unescaping
+
+data FormatError
+  = InvalidFirstChar
+  -- ^ JSON Pointers must either be empty or start with a @/@.
+  | UnescapedTilde
+  deriving (Eq, Show)
+
+
+-- | JSON Pointers must either be empty or start with a @/@. This means
+-- that if you're turning a URI Fragment into a JSON Pointer you must
+-- drop the initial @#@.
+--
+-- Note that the unescaping happening here is not the same as URI
+-- decoding. If you are turning a URI fragment into a JSON Pointer you
+-- must URI decode the 'Text' before using it as an argument to this
+-- function. There's an example of how to do this in the tests using
+-- "Network.HTTP.Types.URI.urlDecode" from http-types.
+unescape :: Text -> Either FormatError Pointer
+unescape txt =
+  case T.splitOn "/" txt of
+    []    -> Right (Pointer [])
+    "":xs -> Pointer <$> traverse f xs
+    _     -> Left InvalidFirstChar
+  where
+    f :: Text -> Either FormatError Token
+    f t = case unescapeToken t of
+            Nothing  -> Left UnescapedTilde
+            Just tok -> Right tok
+
+-- | For internal use by 'unescape'.
+unescapeToken :: Text -> Maybe Token
+unescapeToken t
+  | not (isValid t) = Nothing
+  | otherwise       = Just . Token . replace $ t
+  where
+    -- All tildes must be followed by 0s or 1s.
+    isValid :: Text -> Bool
+    isValid x = all (\y -> T.isPrefixOf "0" y || T.isPrefixOf "1" y) afterTildes
+      where
+        afterTildes :: [Text]
+        afterTildes = drop 1 $ T.splitOn "~" x
+
+    replace :: Text -> Text
+    replace = T.replace "~0" "~" . T.replace "~1" "/"
+
+-- * Resolution
+
+data ResolutionError
+  = ObjectLookupFailed
+  | ArrayIndexInvalid
+  | ArrayElemNotFound
+  | ExpectedObjectOrArray
+  deriving (Eq, Show)
+
+resolve :: Pointer -> Value -> Either ResolutionError Value
+resolve (Pointer []) v     = Right v
+resolve (Pointer (t:ts)) v = resolveToken t v >>= resolve (Pointer ts)
+
+-- | For internal use (or specialized applications that don't want to
+-- resolve an entire pointer at once).
+resolveToken :: Token -> Value -> Either ResolutionError Value
+resolveToken tok (Array vs) =
+  case readMaybe . T.unpack . _unToken $ tok of
+    Nothing -> Left ArrayIndexInvalid
+    Just n  -> do
+      when (n < 0) (Left ArrayIndexInvalid)
+      case vs V.!? n of
+        Nothing  -> Left ArrayElemNotFound
+        Just res -> Right res
+resolveToken tok (Object h) =
+  case H.lookup (_unToken tok) h of
+    Nothing  -> Left ObjectLookupFailed
+    Just res -> Right res
+resolveToken _ _ = Left ExpectedObjectOrArray

src/Data/JsonPointer.hs

@@ -1,79 +0,0 @@
-module Data.JsonPointer where
-
-import           Control.Applicative
-import           Control.Monad
-import           Data.Aeson
-import qualified Data.HashMap.Strict as H
-import           Data.Text           (Text)
-import qualified Data.Text           as T
-import qualified Data.Vector         as V
-import           Text.Read           (readMaybe)
-
-newtype JsonPointer = JsonPointer { _unJsonPointer :: [Text] } deriving (Eq, Show)
-
-data PointerFormatError
-  -- | The Text to build a JSON Pointer must either be empty
-  -- or start with a "/".
-  = InvalidFirstChar
-  | UnescapedTilde
-  deriving (Eq, Show)
-
-data ResolutionError
-  = ObjectLookupFailed
-  | ArrayIndexInvalid
-  | ArrayElemNotFound
-  | ExpectedObjectOrArray
-  deriving (Eq, Show)
-
--- | The Text to build a JSON Pointer must either be empty or start
--- with a "/". If you're turning a URI Fragment into a JSON Pointer
--- you must drop the initial "#".
-jsonPointer :: Text -> Either PointerFormatError JsonPointer
-jsonPointer t =
-  JsonPointer <$> (unescape =<< process (T.splitOn "/" t))
-  where
-    process ::[Text] -> Either PointerFormatError [Text]
-    process []     = Right []
-    process (x:xs)
-      -- This checks that the JsonPointer started with a "/":
-      | (not . T.null $ x) = Left InvalidFirstChar
-      | otherwise          = Right xs
-
-    unescape :: [Text] -> Either PointerFormatError [Text]
-    unescape xs = do
-      void $ mapM checkValid xs
-      Right $ T.replace "~0" "~" . T.replace "~1" "/" <$> xs
-
-    checkValid :: Text -> Either PointerFormatError ()
-    checkValid x = do
-      let afterTildes = drop 1 $ T.splitOn "~" x
-      if all (\y -> T.isPrefixOf "0" y || T.isPrefixOf "1" y) afterTildes
-        then Right ()
-        else Left UnescapedTilde
-
-resolvePointer :: JsonPointer -> Value -> Either ResolutionError Value
-resolvePointer p v =
-  case _unJsonPointer p of
-    [] -> Right v
-    _  -> resolveRefTok p v >>= uncurry resolvePointer
-
--- | For internal use and specialized applications that don't want to
--- resolve the entire pointer at once.
-resolveRefTok :: JsonPointer -> Value -> Either ResolutionError (JsonPointer, Value)
-resolveRefTok p v = do
-  case _unJsonPointer p of
-    []       -> Right (p, v)
-    (tok:ps) ->
-      case v of
-        Object h ->
-          case H.lookup tok h of
-            Nothing -> Left ObjectLookupFailed
-            Just vv -> Right (JsonPointer ps, vv)
-        Array vs -> do
-          case readMaybe (T.unpack tok) of
-            Nothing -> Left ArrayIndexInvalid
-            Just n  -> do
-              when (n < 0)            $ Left ArrayIndexInvalid
-              when (n >= V.length vs) $ Left ArrayElemNotFound
-              Right (JsonPointer ps, vs V.! n)
-        _ -> Left ExpectedObjectOrArray

tests/Unit.hs

@@ -1,87 +1,90 @@
+
 module Main where
 
-import           Control.Applicative
 import           Control.Arrow
-import           Control.Monad
 import           Data.Aeson
-import qualified Data.HashMap.Strict            as H
-import           Data.JsonPointer
-import           Data.Monoid
-import           Data.Text                      (Text)
-import qualified Data.Text                      as T
+import qualified Data.Aeson.Pointer                   as P
+import           Data.Text                            (Text)
+import qualified Data.Text                            as T
 import           Data.Text.Encoding
-import qualified Data.Vector                    as V
-import           Network.HTTP.Types.URI
-import           Test.Framework                 (defaultMain, testGroup)
-import           Test.Framework.Providers.HUnit (testCase)
-import           Test.HUnit                     hiding (Test)
+import qualified Data.Vector                          as V
+import           Network.HTTP.Types.URI               (urlDecode)
+import           Test.Framework                       (defaultMain, testGroup)
+import           Test.Framework.Providers.HUnit       (testCase)
+import           Test.Framework.Providers.QuickCheck2 (testProperty)
+import           Test.HUnit                           hiding (Test)
 
+-- For GHCs before 7.10:
+import           Control.Applicative
+import           Data.Foldable
+import           Data.Monoid
 
 main :: IO ()
 main = defaultMain
   [ testGroup "unit"
-    [ testCase "Can be represented in a JSON string value" jsonString
+    [ testProperty "Storing a Pointer as JSON doesn't change its value" roundtrip
+    , testCase "Can be represented in a JSON string value" jsonString
     , testCase "Can be represented in a URI fragment identifier" uriFragment
     ]
   ]
 
-specExample :: Value
-specExample =
-  Object $ H.fromList
-    [ ("foo" , Array $ V.fromList ["bar", "baz"])
-    , (""    , Number 0)
-    , ("a/b" , Number 1)
-    , ("c%d" , Number 2)
-    , ("e^f" , Number 3)
-    , ("g|h" , Number 4)
-    , ("i\\j", Number 5)
-    , ("k\"l", Number 6)
-    , (" "   , Number 7)
-    , ("m~n" , Number 8)
-    ]
-
-resolvesTo :: (Text, Value) -> Assertion
-resolvesTo (t, expected) =
-  case jsonPointer t of
-    Left e  -> assertFailure (show e <> " error for pointer: " <> show t)
-    Right p ->
-      assertEqual ("Resolved value for pointer: " <> show t)
-        (Right expected)
-        $ resolvePointer p specExample
+roundtrip :: P.Pointer -> Bool
+roundtrip a = Just a == decode (encode a)
 
 jsonString :: Assertion
-jsonString =
-  void $ mapM resolvesTo
-    [ (""      , specExample)
-    , ("/foo"  , Array $ V.fromList ["bar", "baz"])
-    , ("/foo/0", String "bar")
-    , ("/"     , Number 0)
-    , ("/a~1b" , Number 1)
-    , ("/c%d"  , Number 2)
-    , ("/e^f"  , Number 3)
-    , ("/g|h"  , Number 4)
-    , ("/i\\j" , Number 5)
-    , ("/k\"l" , Number 6)
-    , ("/ "    , Number 7)
-    , ("/m~0n" , Number 8)
-    ]
+jsonString = traverse_ resolvesTo
+  [ (""      , specExample)
+  , ("/foo"  , Array $ V.fromList ["bar", "baz"])
+  , ("/foo/0", String "bar")
+  , ("/"     , Number 0)
+  , ("/a~1b" , Number 1)
+  , ("/c%d"  , Number 2)
+  , ("/e^f"  , Number 3)
+  , ("/g|h"  , Number 4)
+  , ("/i\\j" , Number 5)
+  , ("/k\"l" , Number 6)
+  , ("/ "    , Number 7)
+  , ("/m~0n" , Number 8)
+  ]
 
 uriFragment :: Assertion
-uriFragment =
-  void $ mapM resolvesTo $ first decodeFragment <$>
-    [ ("#"      , specExample)
-    , ("#/foo"  , Array $ V.fromList ["bar", "baz"])
-    , ("#/foo/0", String "bar")
-    , ("#/"     , Number 0)
-    , ("#/a~1b" , Number 1)
-    , ("#/c%25d", Number 2)
-    , ("#/e%5Ef", Number 3)
-    , ("#/g%7Ch", Number 4)
-    , ("#/i%5Cj", Number 5)
-    , ("#/k%22l", Number 6)
-    , ("#/%20"  , Number 7)
-    , ("#/m~0n" , Number 8)
-    ]
+uriFragment = traverse_ resolvesTo . fmap (first decodeFragment) $
+  [ ("#"      , specExample)
+  , ("#/foo"  , Array $ V.fromList ["bar", "baz"])
+  , ("#/foo/0", String "bar")
+  , ("#/"     , Number 0)
+  , ("#/a~1b" , Number 1)
+  , ("#/c%25d", Number 2)
+  , ("#/e%5Ef", Number 3)
+  , ("#/g%7Ch", Number 4)
+  , ("#/i%5Cj", Number 5)
+  , ("#/k%22l", Number 6)
+  , ("#/%20"  , Number 7)
+  , ("#/m~0n" , Number 8)
+  ]
   where
     decodeFragment :: Text -> Text
     decodeFragment = T.drop 1 . decodeUtf8 . urlDecode True . encodeUtf8
+
+resolvesTo :: (Text, Value) -> Assertion
+resolvesTo (t, expected) =
+  case P.unescape t of
+    Left e  -> assertFailure (show e <> " error for pointer: " <> show t)
+    Right p -> assertEqual
+                 ("Resolved value for pointer: " <> show t)
+                 (Right expected)
+                 (P.resolve p specExample)
+
+specExample :: Value
+specExample = object
+  [ "foo"  .= (["bar", "baz"] :: [Text])
+  , ""     .= (0 :: Int)
+  , "a/b"  .= (1 :: Int)
+  , "c%d"  .= (2 :: Int)
+  , "e^f"  .= (3 :: Int)
+  , "g|h"  .= (4 :: Int)
+  , "i\\j" .= (5 :: Int)
+  , "k\"l" .= (6 :: Int)
+  , " "    .= (7 :: Int)
+  , "m~n"  .= (8 :: Int)
+  ]