packages feed

json-query (empty) → 0.1.0.0

raw patch · 8 files changed

+521/−0 lines, 8 filesdep +array-chunksdep +basedep +bytebuildsetup-changed

Dependencies added: array-chunks, base, bytebuild, byteslice, bytestring, json-query, json-syntax, neat-interpolation, primitive, scientific-notation, tasty, tasty-hunit, text, text-short, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for json-query++## 0.1.0.0 -- 2021-03-22++* Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Andrew Martin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Martin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ json-query.cabal view
@@ -0,0 +1,58 @@+cabal-version: 2.4+name: json-query+version: 0.1.0.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+extra-source-files: CHANGELOG.md++library+  exposed-modules:+    Json.Parser+    Json.Path+  build-depends:+    , base >=4.12 && <5+    , json-syntax >=0.2 && <0.3+    , bytebuild >=0.3.5 && <0.4+    , text-short >=0.1.3 && <0.2+    , array-chunks >=0.1.2 && <0.2+    , bytestring >=0.10 && <0.11+    , primitive >=0.7 && <0.8+    , transformers >=0.5.6 && <0.6+    , scientific-notation >=0.1.2 && <0.2+  hs-source-dirs: src+  default-language: Haskell2010+  ghc-options: -Wall -O2++test-suite test+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  other-modules:+    DogHouse+  ghc-options: -Wall -O2+  build-depends:+    , array-chunks+    , base >=4.12.0.0 && <5+    , byteslice >=0.1.3+    , bytestring+    , json-query+    , json-syntax+    , primitive+    , bytebuild+    , tasty >=1.2.3+    , tasty-hunit >=0.10.0.2+    , text-short+    , neat-interpolation >=0.5.1+    , text >=1.2
+ src/Json/Parser.hs view
@@ -0,0 +1,181 @@+{-# language BangPatterns #-}+{-# language BlockArguments #-}+{-# language DeriveFunctor #-}+{-# language DerivingStrategies #-}+{-# language DuplicateRecordFields #-}+{-# language KindSignatures #-}+{-# language LambdaCase #-}+{-# language NamedFieldPuns #-}+{-# language RankNTypes #-}++module Json.Parser+  ( Parser(..)+  , MemberParser(..)+    -- * Run+  , run+    -- * Object Parsing+  , key+  , members+    -- * Arrays+  , smallArray+    -- * Specific Data Constructors+  , object+  , array+  , number+  , boolean+  , string+    -- * Trivial Combinators+  , int+  , word16+  , word64+    -- * Failing+  , fail+    -- * Modified Context +  , contextually+  ) where++import Prelude hiding (fail)++import Control.Monad.ST (runST)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT(ExceptT),runExceptT)+import Data.Foldable (foldlM)+import Data.List (find)+import Data.Primitive (SmallArray)+import Data.Text.Short (ShortText)+import Data.Word (Word16,Word64)+import Json (Value(Object,Array,Number),Member(Member))+import Json.Path (Path(Nil,Key,Index))+import Data.Number.Scientific (Scientific)++import qualified Data.Number.Scientific as SCI+import qualified Data.Primitive as PM+import qualified Json+import qualified Json.Path as Path++newtype Parser a = Parser+  { runParser :: Path -> Either Path a }+  deriving stock Functor++instance Applicative Parser where+  pure a = Parser (\_ -> Right a)+  Parser f <*> Parser g = Parser $ \p -> do+    h <- f p+    y <- g p+    pure (h y)++instance Monad Parser where+  Parser f >>= g = Parser $ \p -> do+    x <- f p+    runParser (g x) p++newtype MemberParser a = MemberParser+  { runMemberParser :: Path -> SmallArray Member -> Either Path a }+  deriving stock Functor++instance Applicative MemberParser where+  pure a = MemberParser (\_ _ -> Right a)+  MemberParser f <*> MemberParser g = MemberParser $ \p mbrs -> do+    h <- f p mbrs+    y <- g p mbrs+    pure (h y)++run :: Parser a -> Either Path a+run (Parser f) = case f Nil of+  Right a -> Right a+  Left e -> Left (Path.reverse e)++fail :: Parser a+fail = Parser (\e -> Left e)++object :: Value -> Parser (SmallArray Member)+object = \case+  Object xs -> pure xs+  _ -> fail++array :: Value -> Parser (SmallArray Value)+array = \case+  Array xs -> pure xs+  _ -> fail++members :: MemberParser a -> SmallArray Member -> Parser a+members (MemberParser f) mbrs = Parser (\p -> f p mbrs)++number :: Value -> Parser Scientific+number = \case+  Number n -> pure n+  _ -> fail++string :: Value -> Parser ShortText+string = \case+  Json.String n -> pure n+  _ -> fail++int :: Scientific -> Parser Int+int m = case SCI.toInt m of+  Just n -> pure n+  _ -> fail++word16 :: Scientific -> Parser Word16+word16 m = case SCI.toWord16 m of+  Just n -> pure n+  _ -> fail++word64 :: Scientific -> Parser Word64+word64 m = case SCI.toWord64 m of+  Just n -> pure n+  _ -> fail++boolean :: Value -> Parser Bool+boolean = \case+  Json.True -> pure True+  Json.False -> pure False+  _ -> fail++-- members :: Parser Value (Chunks Member)+-- members = _++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 p'+    Just Member{value} -> runParser (f value) p'++-- object2 ::+--      (a -> b -> c)+--   -> ShortText -> Parser a+--   -> ShortText -> Parser b+--   -> Parser c+-- 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.+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+    lift (PM.unsafeFreezeSmallArray dst)++errorThunk :: a+{-# noinline errorThunk #-}+errorThunk = errorWithoutStackTrace "Json.Parser: implementation mistake"++-- | Run a parser in a modified context.+contextually :: (Path -> Path) -> Parser a -> Parser a+{-# inline contextually #-}+contextually f (Parser g) = Parser+  (\p ->+    let !p' = f p+     in g p'+  )
+ src/Json/Path.hs view
@@ -0,0 +1,79 @@+{-# language BangPatterns #-}+{-# language MagicHash #-}+{-# language UnboxedTuples #-}++module Json.Path+  ( Path(..)+    -- * Encoding+  , encode+  , builderUtf8+    -- * Lookup+  , query+    -- * Reverse+  , reverse+  ) where++import Prelude hiding (reverse)++import Json (Value(Object,Array),Member(Member))+import Data.Primitive (ByteArray(ByteArray))+import Data.Text.Short (ShortText)+import Data.Bytes.Builder (Builder)+import Data.ByteString.Short.Internal (ShortByteString(SBS))++import qualified Data.Bytes.Chunks as ByteChunks+import qualified Data.Bytes.Builder as Builder+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]\".+    -- Negative numbers result in undefined behavior.+  | Nil+  deriving (Eq,Show)++-- | Encode a path.+--+-- >>> encode (Key "foo" $ Index 5 $ Key "bar" $ Nil)+-- $.foo[5].bar+encode :: Path -> ShortText+encode p = ba2st (ByteChunks.concatU (Builder.run 128 (builderUtf8 p)))++builderUtf8 :: Path -> Builder+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++-- | Search for an element at the given path.+query :: Path -> Value -> Maybe Value+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 _ _ = Nothing++ba2st :: ByteArray -> ShortText+ba2st (ByteArray x) = TS.fromShortByteStringUnsafe (SBS x)++reverse :: Path -> Path+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/DogHouse.hs view
@@ -0,0 +1,123 @@+{-# language ApplicativeDo #-}+{-# language NamedFieldPuns #-}+{-# language OverloadedStrings #-}+{-# language QuasiQuotes #-}++module DogHouse+  ( House(..)+  , Dog(..)+  , decode+  , sampleA+  , sampleB+  , expectationA+  , expectationB+  ) where++import Control.Monad ((>=>))+import Data.ByteString.Short.Internal (ShortByteString(SBS))+import Data.Bytes (Bytes)+import Data.Primitive (ByteArray)+import Data.Primitive (SmallArray)+import Data.Text.Encoding (encodeUtf8)+import Data.Text.Short (ShortText)+import Json.Parser (Parser,MemberParser)+import Json.Path (Path(Key,Index,Nil))+import NeatInterpolation (text)++import qualified Data.ByteString.Short as SBS+import qualified Data.Bytes as Bytes+import qualified Data.Primitive as PM+import qualified GHC.Exts as Exts+import qualified Json+import qualified Json.Parser as P++data House = House+  { address :: !ShortText+  , dogs :: !(SmallArray Dog)+  } deriving (Eq,Show)++data Dog = Dog+  { name :: !ShortText+  , age :: !Int+  , alive :: !Bool+  } deriving (Eq,Show)++decode :: Json.Value -> Either Path House+decode v = P.run (P.object v >>= P.members houseMemberParser)++houseMemberParser :: MemberParser House+houseMemberParser = do+  address <- P.key "address" P.string+  dogs <- P.key "dogs" $ \v -> do+    arr <- P.array v+    flip P.smallArray arr $ \e -> do+      P.object e >>= P.members dogMemberParser+  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}++shortByteStringToByteArray :: ShortByteString -> ByteArray +shortByteStringToByteArray (SBS x) = PM.ByteArray x++expectationA :: Either Path House+expectationA = Right House+  { address = "123 Walsh Street"+  , dogs = Exts.fromList+    [ Dog+      { name = "Fluff"+      , age = 52+      , alive = True+      }+    , Dog+      { name = "McDeath"+      , age = 98+      , alive = False+      }+    ]+  }++expectationB :: Either Path House+expectationB = Left (Key "dogs" $ Index 1 $ Key "age" $ Nil)++sampleA :: Bytes+sampleA = id+  $ Bytes.fromByteArray+  $ shortByteStringToByteArray+  $ SBS.toShort+  $ encodeUtf8+  [text|+  {+    "address": "123 Walsh Street",+    "dogs": [+      { "name": "Fluff",+        "age": 52,+        "alive": true+      },+      { "name": "McDeath",+        "age": 98,+        "alive": false+      }+    ]+  }+  |]++sampleB :: Bytes+sampleB = id+  $ Bytes.fromByteArray+  $ shortByteStringToByteArray+  $ SBS.toShort+  $ encodeUtf8+  [text|+  {+    "address": "123 Walsh Street",+    "dogs": [+      { "name": "Fluff", "age": 52, "alive": true },+      { "name": "McDeath", "age": true, "alive": false }+    ]+  }+  |]
+ test/Main.hs view
@@ -0,0 +1,43 @@+{-# language LambdaCase #-}+{-# language OverloadedStrings #-}++import Json.Path (Path(Key,Index,Nil))+import Test.Tasty (defaultMain,testGroup,TestTree)+import Test.Tasty.HUnit ((@=?))++import qualified Data.Bytes as Bytes+import qualified Json+import qualified Json.Path as Path+import qualified Test.Tasty.HUnit as THU++import qualified DogHouse++main :: IO ()+main = defaultMain tests++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-A" $ case Json.decode DogHouse.sampleA of+      Left _ -> fail "failed to parse into syntax tree" +      Right val ->+        DogHouse.expectationA+        @=?+        DogHouse.decode val+  , THU.testCase "DogHouse-B" $ case Json.decode DogHouse.sampleB of+      Left _ -> fail "failed to parse into syntax tree" +      Right val ->+        DogHouse.expectationB+        @=?+        DogHouse.decode val+  ]