diff --git a/Example.hs b/Example.hs --- 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 --- 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 --- 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 --- 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 @@ 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 @@ 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/Data/Aeson/Pointer.hs deleted file mode 100644 --- a/src/Data/Aeson/Pointer.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# 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 diff --git a/src/JSONPointer.hs b/src/JSONPointer.hs new file mode 100644 --- /dev/null +++ b/src/JSONPointer.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module JSONPointer where + +import Control.Monad (when) +import Data.Aeson +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) + +-- For GHCs before 7.10: +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, Semigroup, Monoid, Generic, Arbitrary) + +instance HA.Hashable Pointer + +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. +-- +-- 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, 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) = + T.cons '/' + . T.intercalate "/" + . fmap (T.replace "/" "~1" . T.replace "~" "~0" . _unToken) + $ ts + +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 + +-------------------------------------------------- +-- * 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 + | 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" "/" + +-- | 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 + 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 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 --- a/test/Unit.hs +++ b/test/Unit.hs @@ -3,15 +3,15 @@ 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 @@ 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 @@ 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