diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -35,10 +35,13 @@ ```haskell import Control.Exception (displayException) -import Data.Aeson (Value, Result(..), fromJSON) +import Data.Aeson (FromJSON, ToJSON, Result(..), Value, fromJSON) import Data.Aeson.Encode.Pretty import Data.Aeson.QQ (aesonQQ) +import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as BSL +import Data.Text (Text) +import GHC.Generics (Generic) ``` The `FromJSON` instance can be used to build a `[Patch]`: @@ -74,7 +77,7 @@ The result is in `Either PatchError`, with `displayException` available to get a user-friendly message. -```haskell +```hs main :: IO () main = either (fail . displayException) (BSL.putStr . encodePretty) result ``` @@ -88,6 +91,60 @@ } ``` +## `AsValue` Example + +The polymorphic `patchAsValue` function is also available, which provides the +following benefits over `patchValue`: + +1. The patches argument can be any `AsValue` (from `aeson-optics`), meaning you + can give it directly a `ByteString`, `Value`, or `Text`. Parse errors turning + it into `[Patch]` will be normalized to `PatchError`. +1. The target argument can be any type with `FromJSON` and `ToJSON`. This means + you can patch any of your domain types directly. `AsValue` would've worked + here too, but your domain types are far less likely to have that instance. + +```haskell +data Dog = Dog + { name :: Text + , isGood :: Bool + } + deriving stock Generic + deriving anyclass (FromJSON, ToJSON) + +fido :: Dog +fido = Dog "fido" False -- gasp! + +bytes :: ByteString +bytes = "[{ \"op\":\"replace\", \"path\":\"/isGood\", \"value\":true }]" + +result2 :: Either PatchError Dog +result2 = patchAsValue bytes fido +``` + +```hs +main :: IO () +main = either (fail . displayException) (BSL.putStr . encodePretty) result2 +``` + +The above program outputs: + +```json +{ + "isGood": true, + "name": "fido" +} +``` + + ## Quality diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -35,10 +35,13 @@ ```haskell import Control.Exception (displayException) -import Data.Aeson (Value, Result(..), fromJSON) +import Data.Aeson (FromJSON, ToJSON, Result(..), Value, fromJSON) import Data.Aeson.Encode.Pretty import Data.Aeson.QQ (aesonQQ) +import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as BSL +import Data.Text (Text) +import GHC.Generics (Generic) ``` The `FromJSON` instance can be used to build a `[Patch]`: @@ -74,7 +77,7 @@ The result is in `Either PatchError`, with `displayException` available to get a user-friendly message. -```haskell +```hs main :: IO () main = either (fail . displayException) (BSL.putStr . encodePretty) result ``` @@ -88,6 +91,60 @@ } ``` +## `AsValue` Example + +The polymorphic `patchAsValue` function is also available, which provides the +following benefits over `patchValue`: + +1. The patches argument can be any `AsValue` (from `aeson-optics`), meaning you + can give it directly a `ByteString`, `Value`, or `Text`. Parse errors turning + it into `[Patch]` will be normalized to `PatchError`. +1. The target argument can be any type with `FromJSON` and `ToJSON`. This means + you can patch any of your domain types directly. `AsValue` would've worked + here too, but your domain types are far less likely to have that instance. + +```haskell +data Dog = Dog + { name :: Text + , isGood :: Bool + } + deriving stock Generic + deriving anyclass (FromJSON, ToJSON) + +fido :: Dog +fido = Dog "fido" False -- gasp! + +bytes :: ByteString +bytes = "[{ \"op\":\"replace\", \"path\":\"/isGood\", \"value\":true }]" + +result2 :: Either PatchError Dog +result2 = patchAsValue bytes fido +``` + +```hs +main :: IO () +main = either (fail . displayException) (BSL.putStr . encodePretty) result2 +``` + +The above program outputs: + +```json +{ + "isGood": true, + "name": "fido" +} +``` + + ## Quality diff --git a/jsonpatch.cabal b/jsonpatch.cabal --- a/jsonpatch.cabal +++ b/jsonpatch.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: jsonpatch -version: 0.3.0.0 +version: 0.3.0.1 license: AGPL-3 license-file: COPYING maintainer: Patrick Brisbin @@ -64,8 +64,8 @@ build-depends: aeson >=2.0.3.0, aeson-optics >=1.2.0.1, - attoparsec >=0.14.4, base >=4.16.4.0 && <5, + bytestring >=0.11.4.0, optics-core >=0.4.1, text >=1.2.5.0, vector >=0.12.3.1 @@ -109,7 +109,8 @@ base >=4.16.4.0 && <5, bytestring >=0.11.4.0, jsonpatch, - markdown-unlit >=0.5.1 + markdown-unlit >=0.5.1, + text >=1.2.5.0 if impl(ghc >=9.8) ghc-options: diff --git a/src/Data/JSON/Patch/Apply.hs b/src/Data/JSON/Patch/Apply.hs --- a/src/Data/JSON/Patch/Apply.hs +++ b/src/Data/JSON/Patch/Apply.hs @@ -35,7 +35,7 @@ Test op -> get op.path val >>= \v -> test v op.value op.path val get :: Pointer -> Value -> Either PatchError Value -get p val = note (PointerNotFound p Nothing) $ val ^? pointerL p +get p val = note (PointerNotFound val p) $ val ^? pointerL p add :: Value -> Pointer -> Value -> Either PatchError Value add v p val = case splitPointer p of @@ -46,7 +46,7 @@ remove :: Pointer -> Value -> Either PatchError Value remove p val = do - void $ get p val + void $ get p val -- thing to remove must exist Right $ val & atPointerL p .~ Nothing test :: Value -> Value -> Pointer -> Value -> Either PatchError Value @@ -59,9 +59,9 @@ case (t, target) of (_, Object _) -> Right () -- everything works on objects - (K _, v) -> Left $ InvalidObjectOperation parent v + (K _, nonObject) -> Left $ InvalidObjectOperation parent nonObject (N n, Array vec) -> do when (n < 0) $ Left $ IndexOutOfBounds parent n vec when (n > V.length vec) $ Left $ IndexOutOfBounds parent n vec - (N _, v) -> Left $ InvalidArrayOperation parent v + (N _, nonArray) -> Left $ InvalidArrayOperation parent nonArray _ -> Right () diff --git a/src/Data/JSON/Patch/Error.hs b/src/Data/JSON/Patch/Error.hs --- a/src/Data/JSON/Patch/Error.hs +++ b/src/Data/JSON/Patch/Error.hs @@ -12,13 +12,14 @@ import Data.JSON.Patch.Prelude -import Data.Aeson (Value) +import Data.Aeson (Value, encode) +import Data.ByteString.Lazy.Char8 as BSL8 import Data.JSON.Pointer import Data.Vector qualified as V data PatchError = ParseError Value String - | PointerNotFound Pointer (Maybe String) + | PointerNotFound Value Pointer | InvalidObjectOperation Pointer Value | InvalidArrayOperation Pointer Value | IndexOutOfBounds Pointer Int (Vector Value) @@ -31,22 +32,22 @@ ParseError v msg -> "Unable to parse Patch(es) from Value: " <> ("\n error: " <> msg) - <> ("\n input: " <> show v) - PointerNotFound ts mType -> + <> ("\n input: " <> showValue v) + PointerNotFound v ts -> "Path " <> pointerToString ts - <> " does not exist" - <> maybe "" (" or is not " <>) mType + <> " does not exist in " + <> showValue v InvalidObjectOperation ts v -> "Cannot perform object operation on non-object at " <> pointerToString ts <> ": " - <> show v + <> showValue v InvalidArrayOperation ts v -> "Cannot perform array operation on non-array at " <> pointerToString ts <> ": " - <> show v + <> showValue v IndexOutOfBounds ts n vec -> "Index " <> show n @@ -59,5 +60,8 @@ TestFailed p actual expected -> "Test failed at " <> pointerToString p - <> ("\n expected: " <> show expected) - <> ("\n actual: " <> show actual) + <> ("\n expected: " <> showValue expected) + <> ("\n actual: " <> showValue actual) + +showValue :: Value -> String +showValue = BSL8.unpack . encode diff --git a/src/Data/JSON/Pointer.hs b/src/Data/JSON/Pointer.hs --- a/src/Data/JSON/Pointer.hs +++ b/src/Data/JSON/Pointer.hs @@ -22,7 +22,6 @@ import Data.Aeson (FromJSON (..), Value, withText) import Data.Aeson.Optics (_JSON) -import Data.Attoparsec.Text import Data.JSON.Pointer.Token import Data.List.NonEmpty qualified as NE import Data.Text qualified as T @@ -37,18 +36,12 @@ parseJSON = withText "Pointer" $ either fail pure . pointerFromText pointerFromText :: Text -> Either String Pointer -pointerFromText = parseOnly pointerP - -pointerP :: Parser Pointer -pointerP = do - ts <- (char '/' *> tokenP `sepBy1` char '/' <|> pure []) <* endOfInput - pure $ Pointer ts - -tokenP :: Parser Token -tokenP = - either (fail . ("invalid token: " <>)) pure - . tokenFromText - =<< takeTill (== '/') +pointerFromText t = do + ts <- case T.uncons t of + Nothing -> Right [] + Just ('/', rest) -> Right $ T.splitOn "/" rest + _ -> Left "A non-empty pointer must begin with /" + Pointer <$> traverse tokenFromText ts pointerToText :: Pointer -> Text pointerToText = ("/" <>) . T.intercalate "/" . map tokenToText . (.tokens) diff --git a/src/Data/JSON/Pointer/Token.hs b/src/Data/JSON/Pointer/Token.hs --- a/src/Data/JSON/Pointer/Token.hs +++ b/src/Data/JSON/Pointer/Token.hs @@ -23,7 +23,7 @@ import Data.Char (isDigit) import Data.Text qualified as T import Optics.Core -import Text.Read (readEither) +import Text.Read (readMaybe) data Token = N Int | E | K Key deriving stock (Eq, Show) @@ -55,10 +55,10 @@ readDigits :: Text -> Either String Int readDigits t | t == "0" = Right 0 - | T.isPrefixOf "0" t = Left "leading zeros" + | T.isPrefixOf "0" t = Left "tokens cannot have leading zeros" | otherwise = - first (\msg -> "could not read digits " <> unpack t <> ": " <> msg) - $ readEither + note ("could not read " <> show t <> " as integer") + $ readMaybe $ unpack t tokenToText :: Token -> Text diff --git a/test/Data/JSON/PatchSpec.hs b/test/Data/JSON/PatchSpec.hs --- a/test/Data/JSON/PatchSpec.hs +++ b/test/Data/JSON/PatchSpec.hs @@ -126,6 +126,8 @@ indent = BSL8.replicate n ' ' config = defConfig {confIndent = Spaces 2} +{- FOURMOLU_DISABLE -} + errorsMap :: [(String, PatchError -> Bool)] errorsMap = [ ("JSON Pointer should start with a slash", isParseError) @@ -144,10 +146,7 @@ , ("move op shouldn't work with bad number", isPointerNotFound) , ("null is not valid value for 'path'", isParseError) , ("number is not equal to string", isTestFailed) - , - ( "path /a does not exist -- missing objects are not created recursively" - , isPointerNotFound - ) + , ("path /a does not exist -- missing objects are not created recursively", isPointerNotFound) , ("remove op shouldn't remove from array with bad number", isPointerNotFound) , ("removing a nonexistent field should fail", isPointerNotFound) , ("removing a nonexistent index should fail", isPointerNotFound) @@ -159,6 +158,8 @@ , ("test op should reject the array value, it has leading zeros", isParseError) , ("test op shouldn't get array element 1", isPointerNotFound) ] + +{- FOURMOLU_ENABLE -} isParseError :: PatchError -> Bool isParseError = \case