diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright John Ky (c) 2016 + +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 Author name here 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +# hw-mquery +[![0.0-branch](https://circleci.com/gh/haskell-works/hw-mquery/tree/0.0-branch.svg?style=svg)](https://circleci.com/gh/haskell-works/hw-mquery/tree/0.0-branch) + +``` +λ> import HaskellWorks.Data.MQuery +λ> import qualified Data.DList as DL +λ> !json <- loadJsonPartial "data/78mb.json" +λ> let q = MQuery (DL.singleton json) +λ> q >>= expandArray >>= expandObject +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hw-mquery.cabal b/hw-mquery.cabal new file mode 100644 --- /dev/null +++ b/hw-mquery.cabal @@ -0,0 +1,73 @@ +name: hw-mquery +version: 0.0.0.1 +synopsis: Conduits for tokenizing streams. +description: Please see README.md +homepage: http://github.com/haskell-works/hw-mquery#readme +license: BSD3 +license-file: LICENSE +author: John Ky +maintainer: newhoggy@gmail.com +copyright: 2016 John Ky +category: Data, Conduit +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.22 + +library + hs-source-dirs: src + exposed-modules: HaskellWorks.Data.LoadJson + , HaskellWorks.Data.Micro + , HaskellWorks.Data.Mini + , HaskellWorks.Data.MQuery + build-depends: base >= 4 && < 5 + , array + , attoparsec + , bytestring + , conduit + , containers + , dlist + , hw-bits + , hw-conduit + , hw-diagnostics + , hw-json + , hw-parser + , hw-prim >= 0.0.3.1 + , hw-rankselect >= 0.0.0.5 + , mmap + , mono-traversable + , resourcet + , text + , vector + , word8 + + default-language: Haskell2010 + ghc-options: -Wall -O2 -msse4.2 + +test-suite hw-mquery-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: HaskellWorks.Data.MQuerySpec + build-depends: base >= 4 && < 5 + , attoparsec + , bytestring + , containers + , conduit + , hspec + , hw-bits + , hw-conduit + , hw-mquery + , hw-prim >= 0.0.3.1 + , hw-rankselect >= 0.0.0.5 + , mmap + , parsec + , QuickCheck + , resourcet + , transformers + , vector + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/haskell-works/hw-mquery diff --git a/src/HaskellWorks/Data/LoadJson.hs b/src/HaskellWorks/Data/LoadJson.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/LoadJson.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.LoadJson where + +import Control.Monad +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Decode +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.Json.PartialValue +import HaskellWorks.Data.Json.Succinct.Cursor +import HaskellWorks.Data.Json.Succinct.Index +import HaskellWorks.Data.Json.Succinct.PartialIndex +import HaskellWorks.Data.Json.Value +import HaskellWorks.Data.Succinct.BalancedParens.Simple +import HaskellWorks.Diagnostics.Time + +readJson :: String -> IO (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) +readJson path = do + bs <- BS.readFile path + putStrLn "Read file" + !cursor <- measure (fromByteString bs :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + putStrLn "Created cursor" + return cursor + +loadJson :: String -> IO (Either DecodeError [JsonValue]) +loadJson filename = do + !cursor <- readJson filename + let !jsonResult = (jsonIndexAt >=> jsonValueAt) cursor + return $ (:[]) `fmap` jsonResult + +loadJsonPartial :: String -> IO JsonPartialValue +loadJsonPartial filename = do + !cursor <- readJson filename + let !jsonResult = jsonPartialJsonValueAt (jsonPartialIndexAt cursor) + return jsonResult diff --git a/src/HaskellWorks/Data/MQuery.hs b/src/HaskellWorks/Data/MQuery.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/MQuery.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module HaskellWorks.Data.MQuery where + +import Control.Monad +import qualified Data.DList as DL +import GHC.Base +import HaskellWorks.Data.Json.PartialValue +import HaskellWorks.Data.Mini + +newtype MQuery a = MQuery (DL.DList a) + +deriving instance Functor MQuery +deriving instance Applicative MQuery +deriving instance Monad MQuery +deriving instance Alternative MQuery +deriving instance MonadPlus MQuery + +instance Show (MQuery JsonPartialValue) where + showsPrec _ (MQuery das) = shows (Mini (Mini `fmap` das)) + +instance Show (MQuery (String, JsonPartialValue)) where + showsPrec _ (MQuery das) = shows (Mini (Mini `fmap` das)) + +expandArray :: JsonPartialValue -> MQuery JsonPartialValue +expandArray jpv = case jpv of + JsonPartialArray es -> MQuery $ DL.fromList es + _ -> MQuery DL.empty + +expandObject :: JsonPartialValue -> MQuery (String, JsonPartialValue) +expandObject jpv = case jpv of + JsonPartialObject fs -> MQuery $ DL.fromList fs + _ -> MQuery DL.empty + +selectField :: String -> (String, JsonPartialValue) -> MQuery JsonPartialValue +selectField fieldName (fieldName', jpv) | fieldName == fieldName' = MQuery $ DL.singleton jpv +selectField _ _ = MQuery DL.empty + +jsonKeys :: JsonPartialValue -> [String] +jsonKeys jpv = case jpv of + JsonPartialObject fs -> fst `map` fs + _ -> [] + +hasKey :: String -> JsonPartialValue -> Bool +hasKey fieldName jpv = fieldName `elem` jsonKeys jpv + +inArray :: MQuery JsonPartialValue -> MQuery JsonPartialValue +inArray jpvs = jpvs >>= expandArray + +jsonSize :: JsonPartialValue -> MQuery JsonPartialValue +jsonSize jpv = case jpv of + JsonPartialArray es -> MQuery (DL.singleton (JsonPartialNumber (fromIntegral (length es)))) + JsonPartialObject es -> MQuery (DL.singleton (JsonPartialNumber (fromIntegral (length es)))) + _ -> MQuery (DL.singleton (JsonPartialNumber 0)) diff --git a/src/HaskellWorks/Data/Micro.hs b/src/HaskellWorks/Data/Micro.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Micro.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Micro where + +import qualified Data.DList as DL +import Data.List +import HaskellWorks.Data.Json.PartialValue + +newtype Micro a = Micro a + +instance Show (Micro JsonPartialValue) where + showsPrec _ v = case v of + Micro (JsonPartialString s ) -> shows s + Micro (JsonPartialNumber n ) -> shows n + Micro (JsonPartialObject []) -> ("{}" ++) + Micro (JsonPartialObject _ ) -> ("{..}" ++) + Micro (JsonPartialArray [] ) -> ("[]" ++) + Micro (JsonPartialArray _ ) -> ("[..]" ++) + Micro (JsonPartialBool w ) -> shows w + Micro JsonPartialNull -> ("null" ++) + Micro (JsonPartialError s ) -> ("" ++) + +instance Show (Micro (String, JsonPartialValue)) where + showsPrec _ (Micro (fieldName, jpv)) = shows fieldName . (": " ++) . shows (Micro jpv) + +instance Show a => Show (Micro [a]) where + show (Micro xs) = case length xs of + xsLen | xsLen == 0 -> "[]" + xsLen | xsLen <= 50 -> "[" ++ intercalate ", " (show `map` xs) ++ "]" + _ -> "[" ++ intercalate ", " (show `map` take 50 xs) ++ ", ..]" + +instance Show a => Show (Micro (DL.DList a)) where + showsPrec _ (Micro dxs) = case DL.toList dxs of + xs@(_:_:_:_:_:_:_:_:_:_:_:_:_) -> (("[" ++ intercalate ", " (show `map` take 50 xs) ++ ", ..]") ++) + [] -> ("[]" ++) + xs -> (("[" ++ intercalate ", " (show `map` xs) ++ "]") ++) diff --git a/src/HaskellWorks/Data/Mini.hs b/src/HaskellWorks/Data/Mini.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Mini.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Mini where + +import qualified Data.DList as DL +import Data.List +import HaskellWorks.Data.Json.PartialValue +import HaskellWorks.Data.Micro + +newtype Mini a = Mini a + +instance Show a => Show (Mini [a]) where + show (Mini xs) = case length xs of + xsLen | xsLen == 0 -> "[]" + xsLen | xsLen <= 50 -> "[" ++ intercalate ", " (show `map` xs) ++ "]" + _ -> "[" ++ intercalate ", " (show `map` take 50 xs) ++ ", ..]" + +instance Show a => Show (Mini (DL.DList a)) where + showsPrec _ (Mini dxs) = case DL.toList dxs of + xs@(_:_:_:_:_:_:_:_:_:_:_:_:_) -> (("[" ++ intercalate ", " (show `map` take 50 xs) ++ ", ..]") ++) + [] -> ("[]" ++) + xs -> (("[" ++ intercalate ", " (show `map` xs) ++ "]") ++) + +instance Show (Mini JsonPartialValue) where + showsPrec _ mjpv = case mjpv of + Mini (JsonPartialString s ) -> shows s + Mini (JsonPartialNumber n ) -> shows n + Mini (JsonPartialObject [] ) -> ("{}" ++) + Mini (JsonPartialObject kvs ) -> case kvs of + (_:_:_:_:_:_:_:_:_:_:_:_:_) -> ("{" ++) . showKvs kvs . (", ..}" ++) + [] -> ("{}" ++) + _ -> ("{" ++) . showKvs kvs . ("}" ++) + Mini (JsonPartialArray [] ) -> ("[]" ++) + Mini (JsonPartialArray vs ) -> case vs of + (_:_:_:_:_:_:_:_:_:_:_:_:_) -> ("[" ++) . showVs vs . (", ..]" ++) + [] -> ("[]" ++) + _ -> ("[" ++) . showVs vs . ("]" ++) + Mini (JsonPartialBool w ) -> shows w + Mini JsonPartialNull -> ("null" ++) + Mini (JsonPartialError s ) -> ("" ++) + where showKvs :: [(String, JsonPartialValue)] -> String -> String + showKvs (kv:kvs) = shows (Micro kv) . foldl (.) id ((\jv -> (", " ++) . shows (Micro jv)) `map` kvs) + showKvs [] = id + showVs :: [JsonPartialValue] -> String -> String + showVs (kv:kvs) = shows (Micro kv) . foldl (.) id ((\jv -> (", " ++) . shows (Micro jv)) `map` kvs) + showVs [] = id + +instance Show (Mini (String, JsonPartialValue)) where + showsPrec _ (Mini (fieldName, jpv)) = shows fieldName . (": " ++) . shows (Mini jpv) diff --git a/test/HaskellWorks/Data/MQuerySpec.hs b/test/HaskellWorks/Data/MQuerySpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/MQuerySpec.hs @@ -0,0 +1,12 @@ +module HaskellWorks.Data.MQuerySpec (spec) where + +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{-# ANN module ("HLint: redundant bracket" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.MQuerySpec" $ do + it "Stub" $ do + 1 `shouldBe` (1 :: Int) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}