json-query 0.2.2.0 → 0.2.3.0
raw patch · 12 files changed
+518/−403 lines, 12 filesdep +hspecdep +tasty-hspecdep ~scientific-notationPVP ok
version bump matches the API change (PVP)
Dependencies added: hspec, tasty-hspec
Dependency ranges changed: scientific-notation
API changes (from Hackage documentation)
+ Json.Parser: word32 :: Scientific -> Parser Word32
Files
- CHANGELOG.md +4/−0
- json-query.cabal +44/−37
- src/Json/Arrow.hs +76/−62
- src/Json/Context.hs +25/−19
- src/Json/Error.hs +11/−14
- src/Json/Errors.hs +25/−21
- src/Json/Parser.hs +93/−66
- src/Json/Path.hs +71/−50
- test/Arrowy.hs +8/−13
- test/DogHouse.hs +42/−39
- test/Main.hs +103/−68
- test/Monadic.hs +16/−14
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for json-query +## 0.2.3.0 -- 2024-01-18++* Add `Json.Parser.word32`+ ## 0.2.2.0 -- 2023-08-09 * Add `Json.Errors.hPut` to make it less verbose to print
json-query.cabal view
@@ -1,19 +1,20 @@-cabal-version: 2.4-name: json-query-version: 0.2.2.0-synopsis: Kitchen sink for querying JSON+cabal-version: 2.4+name: json-query+version: 0.2.3.0+synopsis: Kitchen sink for querying JSON description: The library complements json-syntax by making available several common access patterns. The utilities provided by this library only query JSON. They do not update it.-bug-reports: https://github.com/andrewthad/json-query-license: BSD-3-Clause-license-file: LICENSE-author: Andrew Martin-maintainer: andrew.thaddeus@gmail.com-copyright: 2020 Andrew Martin-category: Data-build-type: Simple++bug-reports: https://github.com/andrewthad/json-query+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2020 Andrew Martin+category: Data+build-type: Simple extra-source-files: CHANGELOG.md library@@ -24,44 +25,50 @@ Json.Errors Json.Parser Json.Path+ build-depends:- , array-chunks >=0.1.2 && <0.2- , base >=4.12 && <5- , bytebuild >=0.3.5 && <0.4- , bytestring >=0.10 && <0.12- , contiguous >=0.6.1- , json-syntax >=0.2.2 && <0.3- , primitive >=0.7 && <0.10- , primitive-unlifted >=0.1.3 && <2.2- , profunctors >=5.6- , scientific-notation >=0.1.5 && <0.2- , text-short >=0.1.3 && <0.2- , transformers >=0.5.6 && <0.6- hs-source-dirs: src+ , array-chunks >=0.1.2 && <0.2+ , base >=4.12 && <5+ , bytebuild >=0.3.5 && <0.4+ , bytestring >=0.10 && <0.12+ , contiguous >=0.6.1+ , json-syntax >=0.2.2 && <0.3+ , primitive >=0.7 && <0.10+ , primitive-unlifted >=0.1.3 && <2.2+ , profunctors >=5.6+ , scientific-notation >=0.1.5 && <0.2+ , text-short >=0.1.3 && <0.2+ , transformers >=0.5.6 && <0.7++ hs-source-dirs: src default-language: Haskell2010- ghc-options: -Wall -O2+ ghc-options: -Wall -O2 test-suite test default-language: Haskell2010- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Main.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs other-modules: Arrowy DogHouse Monadic- ghc-options: -Wall -O2++ ghc-options: -Wall -O2 build-depends: , array-chunks- , base >=4.12.0.0 && <5- , byteslice >=0.1.3+ , base >=4.12.0.0 && <5+ , bytebuild+ , byteslice >=0.1.3 , bytestring+ , hspec >=2.11.7 , json-query , json-syntax+ , neat-interpolation >=0.5.1 , primitive- , bytebuild- , tasty >=1.2.3- , tasty-hunit >=0.10.0.2+ , scientific-notation ==0.1.6.0+ , tasty >=1.2.3+ , tasty-hspec >=1.2.0.4+ , tasty-hunit >=0.10.0.2+ , text >=1.2 , text-short- , neat-interpolation >=0.5.1- , text >=1.2
src/Json/Arrow.hs view
@@ -8,9 +8,11 @@ module Json.Arrow ( Parser , type (~>)- -- * Run Parser++ -- * Run Parser , run- -- * Primitive Parsers++ -- * Primitive Parsers , object , array , string@@ -18,48 +20,51 @@ , number , boolean , null- -- ** Object Members- , Members(..)++ -- ** Object Members+ , Members (..) , member , memberOpt , foldMembers- -- ** Array Elements++ -- ** Array Elements , Elements , foldl' , map- -- * Primitive Combinators++ -- * Primitive Combinators , fail , failZero- -- * Trivial Combinators++ -- * Trivial Combinators , withObject , withArray , fromNull , int , word16 , word64- -- * Conversion++ -- * Conversion , liftMaybe ) where -import Prelude hiding (id, (.), fail, map, null)+import Prelude hiding (fail, id, map, null, (.)) -import Control.Arrow ((>>>))-import Control.Arrow (Arrow(..))-import Control.Arrow (ArrowZero(..),ArrowPlus(..),ArrowChoice(..),ArrowApply(..))-import Control.Category (Category(..))+import Control.Arrow (Arrow (..), ArrowApply (..), ArrowChoice (..), ArrowPlus (..), ArrowZero (..), (>>>))+import Control.Category (Category (..)) import Control.Monad.ST (runST)-import Control.Monad.Trans.Except (ExceptT(ExceptT),runExceptT)+import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) import Data.List (find) import Data.Number.Scientific (Scientific) import Data.Primitive (SmallArray) import Data.Primitive.Unlifted.Array (UnliftedArray)-import Data.Profunctor (Profunctor(..))+import Data.Profunctor (Profunctor (..)) import Data.Text.Short (ShortText)-import Data.Word (Word16,Word64)-import Json (Value(Object,Array,String,Number), Member(Member))-import Json.Context (Context(..))+import Data.Word (Word16, Word64)+import Json (Member (Member), Value (Array, Number, Object, String))+import Json.Context (Context (..))+import Json.Error (Error (..)) import Json.Errors (Errors)-import Json.Error (Error(..)) import qualified Data.Number.Scientific as SCI import qualified Data.Primitive.Contiguous as Arr@@ -67,9 +72,12 @@ import qualified Json.Errors as Errors newtype Parser a b = P- { unParser :: Context -- ^ reverse list of json keys & indices that have been entered- -> a -- ^ value to parse- -> Either Errors (Context, b)+ { unParser ::+ Context ->+ -- \^ reverse list of json keys & indices that have been entered+ a ->+ -- \^ value to parse+ Either Errors (Context, b) } type a ~> b = Parser a b @@ -91,20 +99,23 @@ String str -> Right (ctx, str) _ -> Left (Errors.singleton (Error "expected string" ctx)) --- | Parse an array of strings. For example:------ > ["hello","world"]------ Failure context includes the index of non-string value if any values in--- the array are not strings.+{- | Parse an array of strings. For example:++> ["hello","world"]++Failure context includes the index of non-string value if any values in+the array are not strings.+-} strings :: Value ~> UnliftedArray ShortText strings = P $ \ctx v -> case v of Array membs -> runST $ runExceptT $ do- xs <- Arr.itraverseP- (\ix e -> case e of- String s -> pure s- _ -> ExceptT (pure (Left (Errors.singleton (Error "expected string" (Index ix ctx)))))- ) membs+ xs <-+ Arr.itraverseP+ ( \ix e -> case e of+ String s -> pure s+ _ -> ExceptT (pure (Left (Errors.singleton (Error "expected string" (Index ix ctx)))))+ )+ membs pure (ctx, xs) _ -> Left (Errors.singleton (Error "expected array" ctx)) @@ -117,67 +128,68 @@ boolean = P $ \ctx v -> case v of Json.True -> Right (ctx, True) Json.False -> Right (ctx, False)- _ -> Left (Errors.singleton (Error "expected boolean" ctx))+ _ -> Left (Errors.singleton (Error "expected boolean" ctx)) null :: Value ~> () null = P $ \ctx v -> case v of Json.Null -> Right (ctx, ()) _ -> Left (Errors.singleton (Error "expected null" ctx)) -newtype Members = Members { unMembers :: SmallArray Member }+newtype Members = Members {unMembers :: SmallArray Member} member :: ShortText -> Members ~> Value member k = P $ \ctx xs -> case find keyEq (unMembers xs) of- Just Member{value} -> Right (Key k ctx, value)+ Just Member {value} -> Right (Key k ctx, value) Nothing -> Left (Errors.singleton (Error ("key not found: " <> k) ctx))- where- keyEq Member{key} = k == key+ where+ keyEq Member {key} = k == key -- | An optional member. Returns Nothing if the value is missing. memberOpt :: ShortText -> Members ~> Maybe Value memberOpt k = P $ \ctx xs -> case find keyEq (unMembers xs) of- Just Member{value} -> Right (Key k ctx, Just value)+ Just Member {value} -> Right (Key k ctx, Just value) Nothing -> Right (ctx, Nothing)- where- keyEq Member{key} = k == key+ where+ keyEq Member {key} = k == key foldMembers :: a -> (a -> Member ~> a) -> Members ~> a foldMembers z0 f = P $ \ctx membs -> let xs = unMembers membs loop !z !i = if i < Arr.size xs- then- let x@Member{key} = Arr.index xs i- in case unParser (f z) (Key key ctx) x of- Right (_, z') -> loop z' (i + 1)- Left err -> Left err- else Right (ctx, z)+ then+ let x@Member {key} = Arr.index xs i+ in case unParser (f z) (Key key ctx) x of+ Right (_, z') -> loop z' (i + 1)+ Left err -> Left err+ else Right (ctx, z) in loop z0 0 -newtype Elements = Elements { unElements :: SmallArray Value }+newtype Elements = Elements {unElements :: SmallArray Value} foldl' :: a -> (a -> Value ~> a) -> Elements ~> a foldl' z0 f = P $ \ctx elems -> let xs = unElements elems loop !z !i = if i < Arr.size xs- then case unParser (f z) (Index i ctx) (Arr.index xs i) of- Right (_, z') -> loop z' (i + 1)- Left err -> Left err- else Right (ctx, z)+ then case unParser (f z) (Index i ctx) (Arr.index xs i) of+ Right (_, z') -> loop z' (i + 1)+ Left err -> Left err+ else Right (ctx, z) in loop z0 0 map :: (Value ~> a) -> Elements ~> SmallArray a map (P p) = P $ \ctx (Elements xs) -> runST $ do let !len = length xs dst <- Arr.new len- let loop !i = if i < len- then case p (Index i ctx) (Arr.index xs i) of- Right (_, y) -> do- Arr.write dst i y- loop (i + 1)- Left err -> pure $ Left err- else pure $ Right ()+ let loop !i =+ if i < len+ then case p (Index i ctx) (Arr.index xs i) of+ Right (_, y) -> do+ Arr.write dst i y+ loop (i + 1)+ Left err -> pure $ Left err+ else pure $ Right () loop 0 >>= \case Right _ -> do ys <- Arr.unsafeFreeze dst@@ -243,9 +255,11 @@ failZero = P $ \ctx _ -> Left (Errors.singleton (Error "" ctx)) liftMaybe ::- ShortText -- ^ Message to display on decode error- -> (a -> Maybe b) -- ^ Decode function- -> a ~> b+ -- | Message to display on decode error+ ShortText ->+ -- | Decode function+ (a -> Maybe b) ->+ a ~> b liftMaybe msg f = P $ \ctx x -> case f x of Just y -> Right (ctx, y) Nothing -> Left (Errors.singleton (Error msg ctx))
src/Json/Context.hs view
@@ -1,43 +1,49 @@-{-# language BangPatterns #-}+{-# LANGUAGE BangPatterns #-} module Json.Context- ( Context(..)+ ( Context (..)+ -- * Encoding , builderUtf8+ -- * Conversion , toPath ) where -import Json.Path (Path)-import Data.Text.Short (ShortText) import Data.Bytes.Builder (Builder)+import Data.Text.Short (ShortText)+import Json.Path (Path) import qualified Json.Path as Path --- | A finger into a json value indicating where a parser is--- currently operating. When a parser focuses on a key-value--- pair in a map, it adds 'Key' constructor to the context, and--- when it focuses on an element of an array, it adds an 'Index'--- constructor. Like all zipper-like data structures, it is, in--- a sense, reversed, which makes it cheap to construct while--- parsing.+{- | A finger into a json value indicating where a parser is+currently operating. When a parser focuses on a key-value+pair in a map, it adds 'Key' constructor to the context, and+when it focuses on an element of an array, it adds an 'Index'+constructor. Like all zipper-like data structures, it is, in+a sense, reversed, which makes it cheap to construct while+parsing.+-} data Context = Top | Key !ShortText !Context | Index !Int !Context- deriving (Eq,Show)+ deriving (Eq, Show) --- | Reverse the context, converting it to a 'Path'.--- For example, toPath performs this conversion:------ > 12.bar.foo.Top ==> foo.bar.12.Nil+{- | Reverse the context, converting it to a 'Path'.+For example, toPath performs this conversion:++> 12.bar.foo.Top ==> foo.bar.12.Nil+-} toPath :: Context -> Path-toPath = go Path.Nil where+toPath = go Path.Nil+ where go !acc Top = acc go !acc (Key k xs) = go (Path.Key k acc) xs go !acc (Index i xs) = go (Path.Index i acc) xs --- | Convert 'Context' to textual representation using UTF-8 as the encoding--- scheme. This reverses the context to present it in the expected order.+{- | Convert 'Context' to textual representation using UTF-8 as the encoding+scheme. This reverses the context to present it in the expected order.+-} builderUtf8 :: Context -> Builder builderUtf8 ctx0 = Path.builderUtf8 (toPath ctx0)
src/Json/Error.hs view
@@ -1,21 +1,19 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-} module Json.Error ( -- * Types- Error(..)+ Error (..)+ -- * Encoding , encode , builderUtf8 ) where +import Data.ByteString.Short.Internal (ShortByteString (SBS)) import Data.Bytes.Builder (Builder) import Data.Text.Short (ShortText)-import Json.Context (Context(..))-import Data.ByteString.Short.Internal (ShortByteString(SBS))+import Json.Context (Context (..)) import qualified Data.Bytes.Builder as Builder import qualified Data.Bytes.Chunks as ByteChunks@@ -27,19 +25,18 @@ data Error = Error { message :: !ShortText , context :: !Context- } deriving (Eq,Show)+ }+ deriving (Eq, Show) ba2st :: PM.ByteArray -> ShortText-{-# inline ba2st #-}+{-# INLINE ba2st #-} ba2st (PM.ByteArray x) = TS.fromShortByteStringUnsafe (SBS x) encode :: Error -> ShortText encode p = ba2st (ByteChunks.concatU (Builder.run 128 (builderUtf8 p))) builderUtf8 :: Error -> Builder-builderUtf8 Error{message,context}- = Context.builderUtf8 context- <> Builder.ascii2 ':' ' '- <> Builder.shortTextUtf8 message--+builderUtf8 Error {message, context} =+ Context.builderUtf8 context+ <> Builder.ascii2 ':' ' '+ <> Builder.shortTextUtf8 message
src/Json/Errors.hs view
@@ -1,24 +1,25 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Json.Errors ( -- * Types Errors+ -- * Encoding , encode , builderUtf8 , hPut+ -- * Create , singleton+ -- * Conversion , toSmallArray ) where import Control.Monad.ST (runST)-import Data.ByteString.Short.Internal (ShortByteString(SBS))+import Data.ByteString.Short.Internal (ShortByteString (SBS)) import Data.Bytes.Builder (Builder) import Data.Primitive (SmallArray) import Data.Text.Short (ShortText)@@ -50,30 +51,32 @@ singleton :: Error -> Errors singleton = ErrorsOne --- | Convert errors to builder. The errors are separated by--- a pair of characters: comma and space.+{- | Convert errors to builder. The errors are separated by+a pair of characters: comma and space.+-} builderUtf8 :: Errors -> Builder builderUtf8 errs = let len = countErrors errs errArr = makeErrorArray len errs in Error.builderUtf8 (PM.indexSmallArray errArr 0)- <>- Arr.foldMap- (\e -> Builder.ascii2 ',' ' ' <> Error.builderUtf8 e)- (Arr.slice errArr 1 (len - 1))+ <> Arr.foldMap+ (\e -> Builder.ascii2 ',' ' ' <> Error.builderUtf8 e)+ (Arr.slice errArr 1 (len - 1)) --- | Print errors to the provided handle. Typically, @System.IO.stderr@--- is provided as the handle. Each encoded error is suffixed with a newline.------ This is a convenience function for the common case where, after a--- failed parse, an application prints out all parse errors and then exits.+{- | Print errors to the provided handle. Typically, @System.IO.stderr@+is provided as the handle. Each encoded error is suffixed with a newline.++This is a convenience function for the common case where, after a+failed parse, an application prints out all parse errors and then exits.+-} hPut :: Handle -> Errors -> IO () hPut h errs = do let len = countErrors errs errArr = makeErrorArray len errs- bldr = Arr.foldMap- (\e -> Error.builderUtf8 e <> Builder.ascii '\n')- errArr+ bldr =+ Arr.foldMap+ (\e -> Error.builderUtf8 e <> Builder.ascii '\n')+ errArr in ByteChunks.hPut h (Builder.run 128 bldr) -- | Convert errors to array.@@ -81,7 +84,7 @@ toSmallArray e = makeErrorArray (countErrors e) e makeErrorArrayErrorThunk :: a-{-# noinline makeErrorArrayErrorThunk #-}+{-# NOINLINE makeErrorArrayErrorThunk #-} makeErrorArrayErrorThunk = errorWithoutStackTrace "Json.Arrow.makeErrorArray: implementation mistake" @@ -102,12 +105,13 @@ -- postcondition: results is greater than 0. countErrors :: Errors -> Int-countErrors = go where- go ErrorsOne{} = 1+countErrors = go+ where+ go ErrorsOne {} = 1 go (ErrorsPlus a b) = go a + go b ba2st :: PM.ByteArray -> ShortText-{-# inline ba2st #-}+{-# INLINE ba2st #-} ba2st (PM.ByteArray x) = TS.fromShortByteStringUnsafe (SBS x) encode :: Errors -> ShortText
src/Json/Parser.hs view
@@ -1,62 +1,71 @@-{-# language BangPatterns #-}-{-# language BlockArguments #-}-{-# language DeriveFunctor #-}-{-# language DerivingStrategies #-}-{-# language DuplicateRecordFields #-}-{-# language KindSignatures #-}-{-# language LambdaCase #-}-{-# language NamedFieldPuns #-}-{-# language RankNTypes #-}-{-# language OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} module Json.Parser- ( Parser(..)- , MemberParser(..)+ ( Parser (..)+ , MemberParser (..)+ -- * Run , run+ -- * Object Parsing , key , keyOptNull , members+ -- * Arrays , smallArray , foldSmallArray , traverseMembers+ -- * Specific Data Constructors , object , array , number , boolean , string+ -- * Trivial Combinators , int , int32 , word16+ , word32 , word64+ -- * Failing , fail- -- * Modified Context ++ -- * Modified Context , contextually ) where import Prelude hiding (fail) -import Control.Applicative (Alternative(..))+import Control.Applicative (Alternative (..)) import Control.Monad.ST (runST) import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (ExceptT(ExceptT),runExceptT)+import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) import Data.Foldable (foldlM) import Data.Int (Int32) import Data.List (find) import Data.Number.Scientific (Scientific) import Data.Primitive (SmallArray) import Data.Text.Short (ShortText)-import Data.Word (Word16,Word64)-import Json (Value(Object,Array,Number),Member(Member))+import Data.Word (Word16, Word32, Word64)+import Json (Member (Member), Value (Array, Number, Object))+ -- import Json.Path (Path(Nil,Key,Index))-import Json.Context (Context(Top,Key,Index))+import Json.Context (Context (Index, Key, Top))+import Json.Error (Error (..)) import Json.Errors (Errors)-import Json.Error (Error(..)) import qualified Data.Number.Scientific as SCI import qualified Data.Primitive as PM@@ -64,8 +73,8 @@ import qualified Json.Errors as Errors newtype Parser a = Parser- { runParser :: Context -> Either Errors a }- deriving stock Functor+ {runParser :: Context -> Either Errors a}+ deriving stock (Functor) instance Applicative Parser where pure a = Parser (\_ -> Right a)@@ -88,8 +97,8 @@ runParser (g x) p newtype MemberParser a = MemberParser- { runMemberParser :: Context -> SmallArray Member -> Either Errors a }- deriving stock Functor+ {runMemberParser :: Context -> SmallArray Member -> Either Errors a}+ deriving stock (Functor) instance Applicative MemberParser where pure a = MemberParser (\_ _ -> Right a)@@ -99,7 +108,7 @@ pure (h y) instance Alternative MemberParser where- empty = MemberParser $ \p _ -> Left (Errors.singleton Error{message=mempty,context=p})+ empty = MemberParser $ \p _ -> Left (Errors.singleton Error {message = mempty, context = p}) a <|> b = MemberParser $ \p mbrs -> case runMemberParser a p mbrs of Right x -> Right x@@ -119,7 +128,7 @@ Left e -> Left e fail :: ShortText -> Parser a-fail !msg = Parser (\e -> Left (Errors.singleton Error{context=e,message=msg}))+fail !msg = Parser (\e -> Left (Errors.singleton Error {context = e, message = msg})) object :: Value -> Parser (SmallArray Member) object = \case@@ -159,6 +168,11 @@ Just n -> pure n _ -> fail "expected number in range [0,2^16)" +word32 :: Scientific -> Parser Word32+word32 m = case SCI.toWord32 m of+ Just n -> pure n+ _ -> fail "expected number in range [0,2^32)"+ word64 :: Scientific -> Parser Word64 word64 m = case SCI.toWord64 m of Just n -> pure n@@ -175,21 +189,22 @@ key :: ShortText -> (Value -> Parser a) -> MemberParser a key !name f = MemberParser $ \p mbrs ->- let !p' = Key name p in- case find (\Member{key=k} -> k == name) mbrs of- Nothing -> Left (Errors.singleton (Error{context=p',message="key not found: " <> name}))- Just Member{value} -> runParser (f value) p'+ let !p' = Key name p+ in case find (\Member {key = k} -> k == name) mbrs of+ Nothing -> Left (Errors.singleton (Error {context = p', message = "key not found: " <> name}))+ Just Member {value} -> runParser (f value) p' --- | Variant of 'key' that supplies the JSON value @null@ to the--- callback if the key is not found. Using this parser combinators implies--- that there is no distinction between @null@ and an absent value in--- the encoding scheme.+{- | Variant of 'key' that supplies the JSON value @null@ to the+callback if the key is not found. Using this parser combinators implies+that there is no distinction between @null@ and an absent value in+the encoding scheme.+-} keyOptNull :: ShortText -> (Value -> Parser a) -> MemberParser a keyOptNull !name f = MemberParser $ \p mbrs -> let !p' = Key name p- val = case find (\Member{key=k} -> k == name) mbrs of+ val = case find (\Member {key = k} -> k == name) mbrs of Nothing -> Json.Null- Just Member{value} -> value+ Just Member {value} -> value in runParser (f val) p' -- object2 ::@@ -197,39 +212,47 @@ -- -> ShortText -> Parser a -- -> ShortText -> Parser b -- -> Parser c--- object2 f ka pa kb pb = Parser $ \p v -> case v +-- object2 f ka pa kb pb = Parser $ \p v -> case v -- elements :: Parser Value (Chunks Value) -- elements = _ --- | Run the same parser against every element in a 'SmallArray'. This adjusts--- the context at each element.+{- | Run the same parser against every element in a 'SmallArray'. This adjusts+the context at each element.+-} smallArray :: (Value -> Parser a) -> SmallArray Value -> Parser (SmallArray a) smallArray f xs = Parser $ \ !p -> runST do let !len = length xs dst <- PM.newSmallArray len errorThunk runExceptT $ do- _ <- foldlM- (\ix x -> do- !y <- ExceptT (pure (runParser (f x) (Index ix p)))- lift (PM.writeSmallArray dst ix y)- pure (ix + 1)- ) 0 xs+ _ <-+ foldlM+ ( \ix x -> do+ !y <- ExceptT (pure (runParser (f x) (Index ix p)))+ lift (PM.writeSmallArray dst ix y)+ pure (ix + 1)+ )+ 0+ xs lift (PM.unsafeFreezeSmallArray dst) --- | Run the parser against every element in a 'SmallArray', updating an--- accumulator at each step. Folds from left to right. This adjusts--- the context at each element. Typically, type @a@ is @Value@.+{- | Run the parser against every element in a 'SmallArray', updating an+accumulator at each step. Folds from left to right. This adjusts+the context at each element. Typically, type @a@ is @Value@.+-} foldSmallArray :: (b -> a -> Parser b) -> b -> SmallArray a -> Parser b-{-# inline foldSmallArray #-}+{-# INLINE foldSmallArray #-} foldSmallArray f acc0 xs = Parser $ \ !p -> runST do -- TODO: make sure tuples get elided runExceptT $ do- (!_,r) <- foldlM- (\( !ix, !acc) x -> do- !acc' <- ExceptT (pure (runParser (f acc x) (Index ix p)))- pure (ix + 1, acc')- ) (0,acc0) xs+ (!_, r) <-+ foldlM+ ( \(!ix, !acc) x -> do+ !acc' <- ExceptT (pure (runParser (f acc x) (Index ix p)))+ pure (ix + 1, acc')+ )+ (0, acc0)+ xs pure r -- | Traverse the members. The adjusts the context at each member.@@ -238,23 +261,27 @@ let !len = length xs dst <- PM.newSmallArray len errorThunk runExceptT $ do- !_ <- foldlM- (\ !ix x@Member{key=k} -> do- !y <- ExceptT (pure (runParser (f x) (Key k p)))- lift (PM.writeSmallArray dst ix y)- pure (ix + 1)- ) 0 xs+ !_ <-+ foldlM+ ( \ !ix x@Member {key = k} -> do+ !y <- ExceptT (pure (runParser (f x) (Key k p)))+ lift (PM.writeSmallArray dst ix y)+ pure (ix + 1)+ )+ 0+ xs lift (PM.unsafeFreezeSmallArray dst) errorThunk :: a-{-# noinline errorThunk #-}+{-# NOINLINE errorThunk #-} errorThunk = errorWithoutStackTrace "Json.Parser: implementation mistake" -- | Run a parser in a modified context. contextually :: (Context -> Context) -> Parser a -> Parser a-{-# inline contextually #-}-contextually f (Parser g) = Parser- (\p ->- let !p' = f p- in g p'- )+{-# INLINE contextually #-}+contextually f (Parser g) =+ Parser+ ( \p ->+ let !p' = f p+ in g p'+ )
src/Json/Path.hs view
@@ -1,98 +1,119 @@-{-# language BangPatterns #-}-{-# language MagicHash #-}-{-# language UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-} module Json.Path- ( Path(..)+ ( Path (..)+ -- * Encoding , encode , builderUtf8+ -- * Lookup , query , query'+ -- * Reverse , reverse ) where import Prelude hiding (reverse) -import Json (Value(Object,Array,Null),Member(Member))-import Data.Primitive (ByteArray(ByteArray))-import Data.Text.Short (ShortText)+import Data.ByteString.Short.Internal (ShortByteString (SBS)) import Data.Bytes.Builder (Builder)-import Data.ByteString.Short.Internal (ShortByteString(SBS))+import Data.Primitive (ByteArray (ByteArray))+import Data.Text.Short (ShortText)+import Json (Member (Member), Value (Array, Null, Object)) -import qualified Data.Bytes.Chunks as ByteChunks import qualified Data.Bytes.Builder as Builder+import qualified Data.Bytes.Chunks as ByteChunks import qualified Data.Primitive as PM import qualified Data.Text.Short.Unsafe as TS -- | A path to an object. data Path- = Key {-# UNPACK #-} !ShortText !Path- -- ^ JSON path element of a key into an object, \"object.key\".- | Index {-# UNPACK #-} !Int !Path- -- ^ JSON path element of an index into an array, \"array[index]\".+ = -- | JSON path element of a key into an object, \"object.key\".+ Key {-# UNPACK #-} !ShortText !Path+ | -- | JSON path element of an index into an array, \"array[index]\". -- Negative numbers result in undefined behavior.+ Index {-# UNPACK #-} !Int !Path | Nil- deriving (Eq,Show)+ deriving (Eq, Show) --- | Encode a path.------ >>> encode (Key "foo" $ Index 5 $ Key "bar" $ Nil)--- $.foo[5].bar+{- | Encode a path.++>>> encode (Key "foo" $ Index 5 $ Key "bar" $ Nil)+-} encode :: Path -> ShortText encode p = ba2st (ByteChunks.concatU (Builder.run 128 (builderUtf8 p))) builderUtf8 :: Path -> Builder-builderUtf8 p0 = Builder.ascii '$' <> go p0 where+builderUtf8 p0 = Builder.ascii '$' <> go p0+ where go Nil = mempty go (Key k p) = Builder.ascii '.' <> Builder.shortTextUtf8 k <> go p go (Index i p) =- Builder.ascii '['- <> Builder.wordDec (fromIntegral i)- <> Builder.ascii ']'- <> go p+ Builder.ascii '['+ <> Builder.wordDec (fromIntegral i)+ <> Builder.ascii ']'+ <> go p --- | Search for an element at the given path. Returns 'Nothing' if--- anything in the path is missing.+{- | Search for an element at the given path. Returns 'Nothing' if+anything in the path is missing.+-} query :: Path -> Value -> Maybe Value-query = go where+query = go+ where go Nil v = Just v- go (Key k p) (Object mbrs) = foldr- (\(Member key val) other -> if key == k- then Just val- else other- ) Nothing mbrs >>= go p- go (Index i p) (Array vs) = if i < PM.sizeofSmallArray vs- then- let !(# e #) = PM.indexSmallArray## vs i- in go p e- else Nothing+ go (Key k p) (Object mbrs) =+ foldr+ ( \(Member key val) other ->+ if key == k+ then Just val+ else other+ )+ Nothing+ mbrs+ >>= go p+ go (Index i p) (Array vs) =+ if i < PM.sizeofSmallArray vs+ then+ let !(# e #) = PM.indexSmallArray## vs i+ in go p e+ else Nothing go _ _ = Nothing --- | Variant of 'query' that returns 'Null' if anything in the path--- is missing.+{- | Variant of 'query' that returns 'Null' if anything in the path+is missing.+-} query' :: Path -> Value -> Value-query' = go where+query' = go+ where go Nil v = v- go (Key k p) (Object mbrs) = go p $ foldr- (\(Member key val) other -> if key == k- then val- else other- ) Null mbrs- go (Index i p) (Array vs) = if i < PM.sizeofSmallArray vs- then- let !(# e #) = PM.indexSmallArray## vs i- in go p e- else Null+ go (Key k p) (Object mbrs) =+ go p $+ foldr+ ( \(Member key val) other ->+ if key == k+ then val+ else other+ )+ Null+ mbrs+ go (Index i p) (Array vs) =+ if i < PM.sizeofSmallArray vs+ then+ let !(# e #) = PM.indexSmallArray## vs i+ in go p e+ else Null go _ _ = Null ba2st :: ByteArray -> ShortText ba2st (ByteArray x) = TS.fromShortByteStringUnsafe (SBS x) reverse :: Path -> Path-reverse = go Nil where+reverse = go Nil+ where go !acc Nil = acc go !acc (Key k xs) = go (Key k acc) xs go !acc (Index i xs) = go (Index i acc) xs
test/Arrowy.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE Arrows #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeOperators #-} module Arrowy@@ -12,15 +10,13 @@ import Prelude hiding (id) -import Control.Arrow ((>>>),(<+>))-import DogHouse(Dog(..),House(..))-import Json.Arrow (type (~>),Members)+import Control.Arrow ((<+>), (>>>))+import DogHouse (Dog (..), House (..))+import Json.Arrow (Members, type (~>))+import Json.Context (Context (Index, Key, Top))+import Json.Error (Error (..)) import Json.Errors (Errors)-import Json.Error (Error(..))-import Json.Context (Context(Key,Index,Top))-import Data.Primitive (SmallArray) -import qualified GHC.Exts as Exts import qualified Json import qualified Json.Arrow as P import qualified Json.Errors as Errors@@ -32,17 +28,16 @@ houseMemberParser = do address <- P.member "address" >>> P.string dogs <- P.member "dogs" >>> P.withArray (P.withObject dogMemberParser)- pure House{address,dogs}+ pure House {address, dogs} dogMemberParser :: Members ~> Dog dogMemberParser = do name <- P.member "name" >>> P.string age <- P.member "age" >>> (P.int <+> P.fromNull 0) alive <- P.member "alive" >>> P.boolean- pure Dog{name,age,alive}+ pure Dog {name, age, alive} badErrors :: Errors badErrors = Errors.singleton (Error "expected number" $ Key "age" $ Index 1 $ Key "dogs" Top)- <>- Errors.singleton (Error "expected null" $ Key "age" $ Index 1 $ Key "dogs" Top)+ <> Errors.singleton (Error "expected null" $ Key "age" $ Index 1 $ Key "dogs" Top)
test/DogHouse.hs view
@@ -1,20 +1,19 @@-{-# language ApplicativeDo #-}-{-# language NamedFieldPuns #-}-{-# language OverloadedStrings #-}-{-# language QuasiQuotes #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} module DogHouse- ( House(..)- , Dog(..)+ ( House (..)+ , Dog (..) , sampleGood , sampleBad , expectationGood ) where -import Data.ByteString.Short.Internal (ShortByteString(SBS))+import Data.ByteString.Short.Internal (ShortByteString (SBS)) import Data.Bytes (Bytes)-import Data.Primitive (ByteArray)-import Data.Primitive (SmallArray)+import Data.Primitive (ByteArray, SmallArray) import Data.Text.Encoding (encodeUtf8) import Data.Text.Short (ShortText) import NeatInterpolation (text)@@ -27,41 +26,45 @@ data House = House { address :: !ShortText , dogs :: !(SmallArray Dog)- } deriving (Eq,Show)+ }+ deriving (Eq, Show) data Dog = Dog { name :: !ShortText , age :: !Int , alive :: !Bool- } deriving (Eq,Show)+ }+ deriving (Eq, Show) -shortByteStringToByteArray :: ShortByteString -> ByteArray +shortByteStringToByteArray :: ShortByteString -> ByteArray shortByteStringToByteArray (SBS x) = PM.ByteArray x expectationGood :: House-expectationGood = House- { address = "123 Walsh Street"- , dogs = Exts.fromList- [ Dog- { name = "Fluff"- , age = 52- , alive = True- }- , Dog- { name = "McDeath"- , age = 98- , alive = False- }- ]- }+expectationGood =+ House+ { address = "123 Walsh Street"+ , dogs =+ Exts.fromList+ [ Dog+ { name = "Fluff"+ , age = 52+ , alive = True+ }+ , Dog+ { name = "McDeath"+ , age = 98+ , alive = False+ }+ ]+ } sampleGood :: Bytes-sampleGood = id- $ Bytes.fromByteArray- $ shortByteStringToByteArray- $ SBS.toShort- $ encodeUtf8- [text|+sampleGood =+ Bytes.fromByteArray $+ shortByteStringToByteArray $+ SBS.toShort $+ encodeUtf8+ [text| { "address": "123 Walsh Street", "dogs": [@@ -78,12 +81,12 @@ |] sampleBad :: Bytes-sampleBad = id- $ Bytes.fromByteArray- $ shortByteStringToByteArray- $ SBS.toShort- $ encodeUtf8- [text|+sampleBad =+ Bytes.fromByteArray $+ shortByteStringToByteArray $+ SBS.toShort $+ encodeUtf8+ [text| { "address": "123 Walsh Street", "dogs": [
test/Main.hs view
@@ -1,88 +1,123 @@-{-# language LambdaCase #-}-{-# language DuplicateRecordFields #-}-{-# language OverloadedStrings #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} import Control.Arrow ((>>>)) import Data.Bifunctor (first) import Data.Bytes (Bytes)-import Json.Error (Error(Error))-import Json.Path (Path(Key,Index,Nil))-import Test.Tasty (defaultMain,testGroup,TestTree)+import Data.Word (Word32, Word64)+import Json.Error (Error (Error))+import Json.Path (Path (Index, Key, Nil))+import Test.Hspec+import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit ((@=?))+import Test.Tasty.Hspec +import qualified Data.Bytes.Text.Ascii as Ascii+import qualified Data.Number.Scientific as SCI import qualified GHC.Exts as Exts-import qualified Data.Bytes as Bytes import qualified Json+import qualified Json.Arrow as A import qualified Json.Context as Ctx+import qualified Json.Error as JE+import qualified Json.Errors as JES+import qualified Json.Parser as P import qualified Json.Path as Path-import qualified Json.Arrow as A-import qualified Json.Errors as Errors import qualified Test.Tasty.HUnit as THU import qualified Arrowy import qualified DogHouse import qualified Monadic-import qualified Json.Error main :: IO ()-main = defaultMain tests+main = do+ hSpecGroup <- testSpec "Hspec Tests" hSpecTests+ defaultMain $ testGroup "All Tests" [hSpecGroup, hUnitTests] -tests :: TestTree-tests = testGroup "Tests"- [ THU.testCase "Json.Path.query-A" $- case Json.decode (Bytes.fromAsciiString "{\"bla\": true, \"foo\" : [ 55 , { \"bar\": false } ] }") of- Left _ -> fail "failed to parse into syntax tree" - Right v -> - Just Json.False- @=?- Path.query (Key "foo" $ Index 1 $ Key "bar" $ Nil) v- , THU.testCase "Json.Path.encode-A" $- "$.foo[1].bar"- @=?- Path.encode (Key "foo" $ Index 1 $ Key "bar" $ Nil)- , THU.testCase "DogHouse-Monadic-A" $ case Json.decode DogHouse.sampleGood of- Left _ -> fail "failed to parse into syntax tree" - Right val ->- Right DogHouse.expectationGood- @=?- Monadic.decode val- , THU.testCase "DogHouse-Monadic-B" $ case Json.decode DogHouse.sampleBad of- Left _ -> fail "failed to parse into syntax tree" - Right val ->- Monadic.expectationBad- @=?- Monadic.decode val- , THU.testCase "DogHouse-Arrowy-A" $ case Json.decode DogHouse.sampleGood of- Left _ -> fail "failed to parse into syntax tree" - Right val ->- Right DogHouse.expectationGood- @=?- Arrowy.decode val- , THU.testCase "DogHouse-Arrowy-B" $ case Json.decode DogHouse.sampleBad of- Left _ -> fail "failed to parse into syntax tree" - Right val ->- Left Arrowy.badErrors- @=?- Arrowy.decode val- , THU.testCase "Arrowy-strings-A" $ case Json.decode sampleArrowyStrings of- Left _ -> fail "failed to parse into syntax tree" - Right val ->- Left- ( Exts.fromList- [ Error- { context = Ctx.Index 2 (Ctx.Key "foo" Ctx.Top)- , message = "expected string"- }- ]- )- @=?- first Errors.toSmallArray (A.run (A.object >>> A.member "foo" >>> A.strings) val)- , THU.testCase "Arrowy-encode-errors" $- "$.dogs[1].age: expected number, $.dogs[1].age: expected null"- @=?- Errors.encode Arrowy.badErrors- ]+hSpecTests :: Spec+hSpecTests =+ describe "Parser" $ do+ describe "word32" $ do+ context "when value is negative" $ do+ it "should fail" $ do+ let input = SCI.small (-1) 0+ let actual = P.runParser (P.word32 input) Ctx.Top+ let expected = Left (JES.singleton JE.Error {JE.message = "expected number in range [0,2^32)", JE.context = Ctx.Top})+ actual `shouldBe` expected + context "when value is zero" $ do+ it "should succeed" $ do+ let input = SCI.small 0 0+ let actual = P.runParser (P.word32 input) Ctx.Top+ let expected = Right 0+ actual `shouldBe` expected++ context "when value is upper bound" $ do+ it "should succeed" $ do+ let input = SCI.fromWord32 (maxBound :: Word32)+ let actual = P.runParser (P.word32 input) Ctx.Top+ let expected = Right (maxBound :: Word32)+ actual `shouldBe` expected++ context "when value is greater than upper bound" $ do+ it "should fail" $ do+ let large :: Word64 = fromIntegral (maxBound :: Word32) + 1+ let input = SCI.fromWord64 large+ let actual = P.runParser (P.word32 input) Ctx.Top+ let expected = Left (JES.singleton JE.Error {JE.message = "expected number in range [0,2^32)", JE.context = Ctx.Top})+ actual `shouldBe` expected++hUnitTests :: TestTree+hUnitTests =+ testGroup+ "HUnit Tests"+ [ THU.testCase "Json.Path.query-A" $+ case Json.decode (Ascii.fromString "{\"bla\": true, \"foo\" : [ 55 , { \"bar\": false } ] }") of+ Left _ -> fail "failed to parse into syntax tree"+ Right v ->+ Just Json.False+ @=? Path.query (Key "foo" $ Index 1 $ Key "bar" Nil) v+ , THU.testCase "Json.Path.encode-A" $+ "$.foo[1].bar"+ @=? Path.encode (Key "foo" $ Index 1 $ Key "bar" Nil)+ , THU.testCase "DogHouse-Monadic-A" $ case Json.decode DogHouse.sampleGood of+ Left _ -> fail "failed to parse into syntax tree"+ Right val ->+ Right DogHouse.expectationGood+ @=? Monadic.decode val+ , THU.testCase "DogHouse-Monadic-B" $ case Json.decode DogHouse.sampleBad of+ Left _ -> fail "failed to parse into syntax tree"+ Right val ->+ Monadic.expectationBad+ @=? Monadic.decode val+ , THU.testCase "DogHouse-Arrowy-A" $ case Json.decode DogHouse.sampleGood of+ Left _ -> fail "failed to parse into syntax tree"+ Right val ->+ Right DogHouse.expectationGood+ @=? Arrowy.decode val+ , THU.testCase "DogHouse-Arrowy-B" $ case Json.decode DogHouse.sampleBad of+ Left _ -> fail "failed to parse into syntax tree"+ Right val ->+ Left Arrowy.badErrors+ @=? Arrowy.decode val+ , THU.testCase "Arrowy-strings-A" $ case Json.decode sampleArrowyStrings of+ Left _ -> fail "failed to parse into syntax tree"+ Right val ->+ Left+ ( Exts.fromList+ [ Error+ { context = Ctx.Index 2 (Ctx.Key "foo" Ctx.Top)+ , message = "expected string"+ }+ ]+ )+ @=? first JES.toSmallArray (A.run (A.object >>> A.member "foo" >>> A.strings) val)+ , THU.testCase "Arrowy-encode-errors" $+ "$.dogs[1].age: expected number, $.dogs[1].age: expected null"+ @=? JES.encode Arrowy.badErrors+ ]+ sampleArrowyStrings :: Bytes-sampleArrowyStrings = Bytes.fromAsciiString- "{\"bla\": true, \"foo\" : [ \"bar\", \"baz\", null, \"hey\"] }"+sampleArrowyStrings =+ Ascii.fromString+ "{\"bla\": true, \"foo\" : [ \"bar\", \"baz\", null, \"hey\"] }"
test/Monadic.hs view
@@ -1,7 +1,6 @@-{-# language ApplicativeDo #-}-{-# language NamedFieldPuns #-}-{-# language OverloadedStrings #-}-{-# language QuasiQuotes #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} module Monadic ( decode@@ -9,11 +8,11 @@ ) where import Control.Monad ((>=>))-import DogHouse(Dog(..),House(..))-import Json.Parser (MemberParser)+import DogHouse (Dog (..), House (..))+import Json.Context (Context (Index, Key, Top))+import Json.Error (Error (..)) import Json.Errors (Errors)-import Json.Error (Error(..))-import Json.Context (Context(Key,Index,Top))+import Json.Parser (MemberParser) import qualified Json import qualified Json.Errors as Errors@@ -29,17 +28,20 @@ arr <- P.array v flip P.smallArray arr $ \e -> do P.object e >>= P.members dogMemberParser- pure (House{address,dogs})+ pure (House {address, dogs}) dogMemberParser :: MemberParser Dog dogMemberParser = do name <- P.key "name" P.string age <- P.key "age" (P.number >=> P.int) alive <- P.key "alive" P.boolean- pure Dog{name,age,alive}+ pure Dog {name, age, alive} expectationBad :: Either Errors House-expectationBad = Left $ Errors.singleton $ Error- { context = Key "age" $ Index 1 $ Key "dogs" $ Top- , message = "expected number"- }+expectationBad =+ Left $+ Errors.singleton $+ Error+ { context = Key "age" $ Index 1 $ Key "dogs" $ Top+ , message = "expected number"+ }