From e9b9827cef0317d23afc17d9f165d1f907b1e3a8 Mon Sep 17 00:00:00 2001 From: Ian Grant Jeffries Date: Thu, 29 Dec 2016 16:47:21 -0500 Subject: [PATCH] 1.1.0.0. + Rename the module to `JSONPointer`. + Bump aeson. + Derive `Semigroup` for `Pointer`. + Reorganize code. --- Example.hs | 15 ++- README.md | 16 ++- changelog.md | 7 ++ hjsonpointer.cabal | 19 ++-- src/{Data/Aeson/Pointer.hs => JSONPointer.hs} | 102 +++++++++++++----- test/Unit.hs | 18 ++-- 6 files changed, 117 insertions(+), 60 deletions(-) rename src/{Data/Aeson/Pointer.hs => JSONPointer.hs} (62%) diff --git a/Example.hs b/Example.hs index ce5bd5f..4d96cd7 100644 --- a/Example.hs +++ b/Example.hs @@ -1,27 +1,26 @@ -{-# LANGUAGE OverloadedStrings #-} module Example where -import Control.Monad (unless) +import Control.Monad (unless) import Data.Aeson -import qualified Data.Aeson.Pointer as P +import qualified JSONPointer as JP main :: IO () main = do -- JSON Pointers must either be empty or start with a /. - pntr1 <- case P.unescape "/foo/0" of + pntr1 <- case JP.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 "/"] + let pntr2 = JP.Pointer [JP.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!") + unless (JP.unescape "/~1" == Right pntr2) (error "ohno!") - print (P.resolve pntr1 document) - print (P.resolve pntr2 document) + print (JP.resolve pntr1 document) + print (JP.resolve pntr2 document) where document :: Value diff --git a/README.md b/README.md index 11d2428..246cf93 100644 --- a/README.md +++ b/README.md @@ -7,30 +7,28 @@ # Example ```haskell -{-# LANGUAGE OverloadedStrings #-} - module Example where -import Control.Monad (unless) +import Control.Monad (unless) import Data.Aeson -import qualified Data.Aeson.Pointer as P +import qualified JSONPointer as JP main :: IO () main = do -- JSON Pointers must either be empty or start with a /. - pntr1 <- case P.unescape "/foo/0" of + pntr1 <- case JP.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 "/"] + let pntr2 = JP.Pointer [JP.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!") + unless (JP.unescape "/~1" == Right pntr2) (error "ohno!") - print (P.resolve pntr1 document) - print (P.resolve pntr2 document) + print (JP.resolve pntr1 document) + print (JP.resolve pntr2 document) where document :: Value diff --git a/changelog.md b/changelog.md index 67412b6..ebebec7 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +# 1.1.0.0 + ++ Rename the module to `JSONPointer`. ++ Bump aeson. ++ Derive `Semigroup` for `Pointer`. ++ Reorganize code. + # 1.0.0.2 + Bump hspec. diff --git a/hjsonpointer.cabal b/hjsonpointer.cabal index 0b68d0c..9987cc7 100644 --- a/hjsonpointer.cabal +++ b/hjsonpointer.cabal @@ -1,5 +1,5 @@ name: hjsonpointer -version: 1.0.0.2 +version: 1.1.0.0 synopsis: JSON Pointer library homepage: https://github.com/seagreen/hjsonpointer license: MIT @@ -17,19 +17,18 @@ library hs-source-dirs: src default-language: Haskell2010 - default-extensions: - OverloadedStrings - other-extensions: - GeneralizedNewtypeDeriving ghc-options: -Wall exposed-modules: - Data.Aeson.Pointer + JSONPointer build-depends: - aeson >= 0.7 && < 1.1 - , base >= 4.6 && < 4.10 + base >= 4.6 && < 4.10 + , aeson >= 0.7 && < 1.2 + , hashable >= 1.2 && < 1.3 , QuickCheck >= 2.8 && < 2.10 , unordered-containers >= 0.2 && < 0.3 + , semigroups >= 0.18 && < 1.0 + -- ^ for GHCs < 8 , text >= 1.2 && < 1.3 , vector >= 0.10 && < 0.12 @@ -49,12 +48,12 @@ test-suite unit aeson , base , hjsonpointer + , hspec >= 2.2 && < 2.4 + , http-types >= 0.8 && < 0.10 , QuickCheck , unordered-containers , text , vector - , hspec >= 2.2 && < 2.4 - , http-types >= 0.8 && < 0.10 source-repository head type: git diff --git a/src/Data/Aeson/Pointer.hs b/src/JSONPointer.hs similarity index 62% rename from src/Data/Aeson/Pointer.hs rename to src/JSONPointer.hs index 03be959..c03f46f 100644 --- a/src/Data/Aeson/Pointer.hs +++ b/src/JSONPointer.hs @@ -1,13 +1,18 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} -module Data.Aeson.Pointer where +module JSONPointer where import Control.Monad (when) import Data.Aeson -import qualified Data.HashMap.Strict as H +import qualified Data.Hashable as HA +import qualified Data.HashMap.Strict as HM +import Data.Semigroup (Semigroup) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as V +import GHC.Generics (Generic) import Test.QuickCheck import Text.Read (readMaybe) @@ -16,9 +21,30 @@ import Control.Applicative import Data.Monoid import Data.Traversable +-------------------------------------------------- +-- * 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) + +-------------------------------------------------- +-- * Main types and escaping +-------------------------------------------------- + newtype Pointer = Pointer { _unPointer :: [Token] } - deriving (Eq, Show, Monoid, Arbitrary) + deriving (Eq, Show, Semigroup, Monoid, Generic, Arbitrary) + +instance HA.Hashable Pointer instance FromJSON Pointer where parseJSON = withText "JSON Pointer" $ \t -> @@ -32,13 +58,22 @@ instance ToJSON Pointer where -- | 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. +-- +-- Since these are unescaped you can write @"/"@ and @"~"@ normally. +-- (e.g. if you're referencing a key such as @"abc/123"@, go ahead +-- and write that exactly. newtype Token = Token { _unToken :: Text } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance HA.Hashable Token instance Arbitrary Token where arbitrary = Token . T.pack <$> arbitrary +-- | This escapes @"/"@ (because it's the token separator character). +-- +-- It also escapes @"~"@ (because it's the escape character). escape :: Pointer -> Text escape (Pointer []) = "" escape (Pointer ts) = @@ -47,15 +82,12 @@ escape (Pointer ts) = . 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 @#@. @@ -77,7 +109,40 @@ unescape txt = Nothing -> Left UnescapedTilde Just tok -> Right tok --- | For internal use by 'unescape'. +-------------------------------------------------- +-- * Wrapper Types +-- +-- These aren't used by the rest of the library +-- (as explained in the docs for 'Token'). +-- +-- However, they might be useful if you need to distinguish JSON Pointer +-- tokens from plain 'Text' or 'Int' without losing information by +-- converting to 'Token'. +-------------------------------------------------- + +-- | A glorified @type@ alias. If you need to do JSON Pointer operations +-- you're looking for 'Token' instead. +-- +-- NOTE: Unlike 'Token' this is escaped. +newtype Key + = Key { _unKey :: Text } + deriving (Eq, Show, Generic) + +instance HA.Hashable Key + +-- | A glorified @type@ alias. If you need to do JSON Pointer operations +-- you're looking for 'Token' instead. +newtype Index + = Index { _unIndex :: Int } + deriving (Eq, Show, Generic) + +instance HA.Hashable Index + +-------------------------------------------------- +-- * Internals +-------------------------------------------------- + +-- | For internal use (by 'unescape'). unescapeToken :: Text -> Maybe Token unescapeToken t | not (isValid t) = Nothing @@ -93,21 +158,10 @@ unescapeToken t 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). +-- | For internal use (by 'resolve'). +-- +-- Might also be useful for 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 @@ -118,7 +172,7 @@ resolveToken tok (Array vs) = Nothing -> Left ArrayElemNotFound Just res -> Right res resolveToken tok (Object h) = - case H.lookup (_unToken tok) h of + case HM.lookup (_unToken tok) h of Nothing -> Left ObjectLookupFailed Just res -> Right res resolveToken _ _ = Left ExpectedObjectOrArray diff --git a/test/Unit.hs b/test/Unit.hs index 4f1b054..48bd6fd 100644 --- a/test/Unit.hs +++ b/test/Unit.hs @@ -3,15 +3,15 @@ module Main where import Control.Arrow import Data.Aeson -import qualified Data.Aeson.Pointer as P -import Data.Text (Text) -import qualified Data.Text as T +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 (urlDecode) +import qualified Data.Vector as V +import qualified JSONPointer as JP +import Network.HTTP.Types.URI (urlDecode) import Test.Hspec -import Test.QuickCheck (property) +import Test.QuickCheck (property) -- For GHCs before 7.10: import Control.Applicative @@ -29,7 +29,7 @@ main = hspec $ do it "can be represented in a JSON string value" jsonString it "can be represented in a URI fragment identifier" uriFragment -roundtrip :: P.Pointer -> Bool +roundtrip :: JP.Pointer -> Bool roundtrip a = Just a == decode (encode a) jsonString :: Expectation @@ -69,9 +69,9 @@ uriFragment = traverse_ resolvesTo . fmap (first decodeFragment) $ resolvesTo :: (Text, Value) -> Expectation resolvesTo (t, expected) = - case P.unescape t of + case JP.unescape t of Left e -> expectationFailure (show e <> " error for pointer: " <> show t) - Right p -> P.resolve p specExample `shouldBe` Right expected + Right p -> JP.resolve p specExample `shouldBe` Right expected specExample :: Value specExample = object