diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -55,7 +55,7 @@ 82 import HaskellWorks.Diagnostics 83 import System.IO.MMap 88 (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr "../data/78mbs.json" ReadOnly Nothing - 276 cursor <- measure (fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + 276 cursor <- measure (fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64))) ## Examples @@ -70,7 +70,7 @@ import Data.Word import System.CPUTime (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr "/Users/jky/Downloads/78mbs.json" ReadOnly Nothing - cursor <- measure (fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + cursor <- measure (fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64))) let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size x <- measure $ jsonBsToInterestBs bs let !y = BS.concat (unescape' "" [bs]) @@ -111,9 +111,8 @@ let fc = TC.firstChild let ns = TC.nextSibling let pn = TC.parent -let cd = TC.depth let ss = TC.subtreeSize -let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) +let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64)) cursor fc cursor (fc >=> ns) cursor diff --git a/app/App/Commands.hs b/app/App/Commands.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands.hs @@ -0,0 +1,13 @@ +module App.Commands where + +import App.Commands.CreateIndex +import Data.Semigroup ((<>)) +import Options.Applicative + +commands :: Parser (IO ()) +commands = commandsGeneral + +commandsGeneral :: Parser (IO ()) +commandsGeneral = subparser $ mempty + <> commandGroup "Commands:" + <> cmdCreateIndex diff --git a/app/App/Commands/CreateIndex.hs b/app/App/Commands/CreateIndex.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/CreateIndex.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module App.Commands.CreateIndex + ( cmdCreateIndex + ) where + +import App.Commands.Types +import Control.Lens +import Data.Semigroup ((<>)) +import Data.Word +import Foreign +import Options.Applicative hiding (columns) + +import qualified App.Lens as L +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Internal as BSI +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Vector.Storable as DVS +import qualified HaskellWorks.Data.Json.Internal.Blank as J +import qualified HaskellWorks.Data.Json.Internal.BlankedJson as J +import qualified HaskellWorks.Data.Json.Internal.MakeIndex as J +import qualified HaskellWorks.Data.Json.Internal.ToBalancedParens64 as J +import qualified System.IO as IO +import qualified System.IO.MMap as IO + +runCreateIndex :: CreateIndexOptions -> IO () +runCreateIndex opts = do + let filePath = opts ^. L.filePath + (fptr :: ForeignPtr Word8, offset, size) <- IO.mmapFileForeignPtr filePath IO.ReadOnly Nothing + let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size + let blankedJson = J.blankJson [bs] + let ibs = LBS.fromChunks (J.blankedJsonToInterestBits blankedJson) + let bps = J.toBalancedParens64 (J.BlankedJson blankedJson) + let vb = DVS.foldl (\b a -> b <> B.word64LE a) mempty bps + LBS.writeFile (filePath <> ".ib.idx") ibs + h <- IO.openFile (filePath <> ".bp.idx") IO.WriteMode + B.hPutBuilder h vb + IO.hClose h + +optsCreateIndex :: Parser CreateIndexOptions +optsCreateIndex = CreateIndexOptions + <$> strOption + ( long "input" + <> short 'i' + <> help "Input JSON file" + <> metavar "STRING" + ) + +cmdCreateIndex :: Mod CommandFields (IO ()) +cmdCreateIndex = command "create-index" $ flip info idm $ runCreateIndex <$> optsCreateIndex diff --git a/app/App/Commands/Demo.hs b/app/App/Commands/Demo.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/Demo.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module App.Commands.Demo + ( cmdDemo + ) where + +import App.Commands.Types +import Control.Lens +import Control.Monad +import Data.Semigroup ((<>)) +import HaskellWorks.Data.Json.LightJson +import HaskellWorks.Data.Json.LoadCursor +import HaskellWorks.Data.Micro +import HaskellWorks.Data.MQuery +import Options.Applicative hiding (columns) + +import qualified App.Lens as L +import qualified Data.DList as DL + +runDemo :: DemoOptions -> IO () +runDemo opts = do + !cursor <- loadJsonWithCsPoppyIndex (opts ^. L.filePath) + let !json = lightJsonAt cursor + let q = MQuery (DL.singleton json) + + putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> entry >=> named "price_currency_code" >=> asString) & count + +optsDemo :: Parser DemoOptions +optsDemo = DemoOptions + <$> strOption + ( long "input" + <> short 'i' + <> help "Input DSV file" + <> metavar "STRING" + ) + +cmdDemo :: Mod CommandFields (IO ()) +cmdDemo = command "create-index" $ flip info idm $ runDemo <$> optsDemo diff --git a/app/App/Commands/Types.hs b/app/App/Commands/Types.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/Types.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module App.Commands.Types + ( CreateIndexOptions(..) + , DemoOptions(..) + ) where + +newtype CreateIndexOptions = CreateIndexOptions + { _createIndexOptionsFilePath :: FilePath + } deriving (Eq, Show) + +newtype DemoOptions = DemoOptions + { _demoOptionsFilePath :: FilePath + } deriving (Eq, Show) diff --git a/app/App/IO.hs b/app/App/IO.hs new file mode 100644 --- /dev/null +++ b/app/App/IO.hs @@ -0,0 +1,27 @@ +module App.IO where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import System.IO (Handle) + +import qualified Data.ByteString.Lazy as LBS +import qualified System.IO as IO + +openOutputFile :: MonadResource m => FilePath -> Maybe Int -> m (ReleaseKey, Handle) +openOutputFile "-" _ = allocate (return IO.stdout) (const (return ())) +openOutputFile filePath maybeBufferSize = allocate open close + where open = do + handle <- IO.openFile filePath IO.WriteMode + forM_ maybeBufferSize $ \bufferSize -> + liftIO $ IO.hSetBuffering handle (IO.BlockBuffering (Just bufferSize)) + return handle + close = IO.hClose + +readInputFile :: FilePath -> IO LBS.ByteString +readInputFile "-" = LBS.hGetContents IO.stdin +readInputFile filePath = LBS.readFile filePath + +writeOutputFile :: FilePath -> LBS.ByteString -> IO () +writeOutputFile "-" bs = LBS.hPut IO.stdout bs +writeOutputFile filePath bs = LBS.writeFile filePath bs diff --git a/app/App/Lens.hs b/app/App/Lens.hs new file mode 100644 --- /dev/null +++ b/app/App/Lens.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module App.Lens where + +import App.Commands.Types +import Control.Lens + +makeFields ''CreateIndexOptions +makeFields ''DemoOptions diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,53 +1,11 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Main where +import App.Commands import Control.Monad -import Data.Function -import Data.Word -import HaskellWorks.Data.BalancedParens.Simple -import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.FromByteString -import HaskellWorks.Data.Json.Cursor -import HaskellWorks.Data.Json.LightJson -import HaskellWorks.Data.Json.LoadCursor -import HaskellWorks.Data.Micro -import HaskellWorks.Data.MQuery - -import qualified Data.ByteString as BS -import qualified Data.DList as DL -import qualified Data.Vector.Storable as DVS - -readJson :: String -> IO (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) -readJson path = do - bs <- BS.readFile path - print ("Read file" :: String) - let !cursor = fromByteString bs :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) - print ("Created cursor" :: String) - return cursor - --- exploreSiblings :: BalancedParens b => b -> Count -> ([Count] -> [Count]) --- exploreSiblings b c = case nextSibling b c of --- Just d -> (d:) . explore b d --- Nothing -> id --- --- exploreChildren :: BalancedParens b => b -> Count -> ([Count] -> [Count]) --- exploreChildren b c = case firstChild b c of --- Just d -> (d:) . explore b d --- Nothing -> id --- --- explore :: BalancedParens b => b -> Count -> ([Count] -> [Count]) --- explore b c = exploreSiblings b c . exploreChildren b c +import Data.Semigroup ((<>)) +import Options.Applicative main :: IO () -main = do - !cursor <- loadJsonWithCsPoppyIndex "../data/78mb.json" - -- let ranks = explore (balancedParens cursor) (cursorRank cursor) - -- putStrLn $ "Ranks: " ++ show (length (ranks [])) - - let !json = lightJsonAt cursor - let q = MQuery (DL.singleton json) - - putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> entry >=> named "price_currency_code" >=> asString) & count +main = join $ customExecParser + (prefs $ showHelpOnEmpty <> showHelpOnError) + (info (commands <**> helper) idm) diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -9,7 +9,6 @@ import Data.Word import Foreign import HaskellWorks.Data.BalancedParens.Simple -import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.FromByteString import HaskellWorks.Data.Json.Cursor import HaskellWorks.Data.Json.Internal.Blank @@ -27,8 +26,8 @@ let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size return bs -loadJson :: BS.ByteString -> JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) -loadJson bs = fromByteString bs :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) +loadJson :: BS.ByteString -> JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64)) +loadJson bs = fromByteString bs :: JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64)) jsonToInterestBits3 :: [BS.ByteString] -> [BS.ByteString] jsonToInterestBits3 = blankedJsonToInterestBits . blankJson diff --git a/hw-json.cabal b/hw-json.cabal --- a/hw-json.cabal +++ b/hw-json.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: hw-json -version: 0.8.1.0 +version: 0.9.0.0 synopsis: Memory efficient JSON parser description: Memory efficient JSON parser. Please see README.md category: Data @@ -51,14 +51,14 @@ , hw-balancedparens >= 0.2.0.1 && < 0.3 , hw-bits >= 0.7.0.2 && < 0.8 , hw-prim >= 0.6.2.0 && < 0.7 - , hw-rankselect >= 0.10 && < 0.11 + , hw-rankselect >= 0.10 && < 0.13 , hw-rankselect-base >= 0.3 && < 0.4 , mmap >= 0.5 && < 0.6 , vector >= 0.12 && < 0.13 , array >= 0.5 && < 0.6 , ansi-wl-pprint >= 0.6.8.2 && < 0.7 , attoparsec >= 0.13 && < 0.14 - , containers >= 0.5 && < 0.6 + , containers >= 0.5 && < 0.7 , dlist >= 0.8 && < 0.9 , hw-mquery >= 0.1 && < 0.2 , hw-parser >= 0.1 && < 0.2 @@ -71,34 +71,35 @@ cpp-options: -DBMI2_ENABLED exposed-modules: HaskellWorks.Data.Json - HaskellWorks.Data.Json.CharLike HaskellWorks.Data.Json.Cursor HaskellWorks.Data.Json.DecodeError HaskellWorks.Data.Json.FromValue HaskellWorks.Data.Json.Internal.Blank + HaskellWorks.Data.Json.Internal.BlankedJson + HaskellWorks.Data.Json.Internal.CharLike + HaskellWorks.Data.Json.Internal.Cursor.Token + HaskellWorks.Data.Json.Internal.IbBp + HaskellWorks.Data.Json.Internal.Index HaskellWorks.Data.Json.Internal.MakeIndex + HaskellWorks.Data.Json.Internal.PartialIndex + HaskellWorks.Data.Json.Internal.ToBalancedParens64 + HaskellWorks.Data.Json.Internal.ToInterestBits64 + HaskellWorks.Data.Json.Internal.Token + HaskellWorks.Data.Json.Internal.Token.Tokenize + HaskellWorks.Data.Json.Internal.Token.Types + HaskellWorks.Data.Json.Internal.Value HaskellWorks.Data.Json.Internal.Words HaskellWorks.Data.Json.LightJson HaskellWorks.Data.Json.Load HaskellWorks.Data.Json.LoadCursor HaskellWorks.Data.Json.PartialValue - HaskellWorks.Data.Json.Succinct.Cursor.BalancedParens - HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson - HaskellWorks.Data.Json.Succinct.Cursor.InterestBits - HaskellWorks.Data.Json.Succinct.Cursor.Token - HaskellWorks.Data.Json.Succinct.Index - HaskellWorks.Data.Json.Succinct.PartialIndex - HaskellWorks.Data.Json.Token - HaskellWorks.Data.Json.Token.Tokenize - HaskellWorks.Data.Json.Token.Types HaskellWorks.Data.Json.Type HaskellWorks.Data.Json.Value - HaskellWorks.Data.Json.Value.Internal other-modules: Paths_hw_json default-language: Haskell2010 -executable hw-json-example +executable hw-json main-is: Main.hs hs-source-dirs: app @@ -109,19 +110,30 @@ , hw-balancedparens >= 0.2.0.1 && < 0.3 , hw-bits >= 0.7.0.2 && < 0.8 , hw-prim >= 0.6.2.0 && < 0.7 - , hw-rankselect >= 0.10 && < 0.11 + , hw-rankselect >= 0.10 && < 0.13 , hw-rankselect-base >= 0.3 && < 0.4 , mmap >= 0.5 && < 0.6 , vector >= 0.12 && < 0.13 - , criterion >= 1.4 && < 1.5 - , dlist >= 0.8 && < 0.9 + , criterion >= 1.4 && < 1.6 + , dlist >= 0.8 && < 0.9 , hw-json - , hw-mquery >= 0.1 && < 0.2 + , hw-mquery >= 0.1 && < 0.2 + , generic-lens >= 1 && < 1.1 + , lens >= 4 && < 5 + , optparse-applicative >= 0.14 && < 0.15 + , resourcet >= 1.2 && < 1.3 if (flag(sse42)) ghc-options: -mbmi2 if (flag(bmi2)) && (impl(ghc >=8.4.1)) ghc-options: -mbmi2 -msse4.2 cpp-options: -DBMI2_ENABLED + other-modules: + App.Commands + App.Commands.CreateIndex + App.Commands.Demo + App.Commands.Types + App.IO + App.Lens default-language: Haskell2010 test-suite hw-json-test @@ -136,12 +148,12 @@ , hw-balancedparens >= 0.2.0.1 && < 0.3 , hw-bits >= 0.7.0.2 && < 0.8 , hw-prim >= 0.6.2.0 && < 0.7 - , hw-rankselect >= 0.10 && < 0.11 + , hw-rankselect >= 0.10 && < 0.13 , hw-rankselect-base >= 0.3 && < 0.4 , mmap >= 0.5 && < 0.6 , vector >= 0.12 && < 0.13 , attoparsec >= 0.13 && < 0.14 - , containers >= 0.5 && < 0.6 + , containers >= 0.5 && < 0.7 , hspec >= 2.5 && < 2.6 , hw-json if (flag(sse42)) @@ -172,11 +184,11 @@ , hw-balancedparens >= 0.2.0.1 && < 0.3 , hw-bits >= 0.7.0.2 && < 0.8 , hw-prim >= 0.6.2.0 && < 0.7 - , hw-rankselect >= 0.10 && < 0.11 + , hw-rankselect >= 0.10 && < 0.13 , hw-rankselect-base >= 0.3 && < 0.4 , mmap >= 0.5 && < 0.6 , vector >= 0.12 && < 0.13 - , criterion >= 1.4 && < 1.5 + , criterion >= 1.4 && < 1.6 , directory >= 1.3 && < 1.4 , hw-json if (flag(sse42)) diff --git a/src/HaskellWorks/Data/Json.hs b/src/HaskellWorks/Data/Json.hs --- a/src/HaskellWorks/Data/Json.hs +++ b/src/HaskellWorks/Data/Json.hs @@ -7,6 +7,5 @@ ( module X ) where -import HaskellWorks.Data.Json.Token as X import HaskellWorks.Data.Json.Type as X import HaskellWorks.Data.Json.Value as X diff --git a/src/HaskellWorks/Data/Json/CharLike.hs b/src/HaskellWorks/Data/Json/CharLike.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Json/CharLike.hs +++ /dev/null @@ -1,23 +0,0 @@ -module HaskellWorks.Data.Json.CharLike where - -import Data.Word -import Data.Word8 -import HaskellWorks.Data.Json.Internal.Words - -class JsonCharLike c where - isLeadingDigit2 :: c -> Bool - isQuotDbl :: c -> Bool - isChar_t :: c -> Bool - isChar_f :: c -> Bool - isChar_n :: c -> Bool - isBraceLeft :: c -> Bool - isBracketLeft :: c -> Bool - -instance JsonCharLike Word8 where - isLeadingDigit2 = isLeadingDigit - isQuotDbl = (== _quotedbl) - isChar_t = (== _t) - isChar_f = (== _f) - isChar_n = (== _n) - isBraceLeft = (== _braceleft) - isBracketLeft = (== _bracketleft) diff --git a/src/HaskellWorks/Data/Json/Cursor.hs b/src/HaskellWorks/Data/Json/Cursor.hs --- a/src/HaskellWorks/Data/Json/Cursor.hs +++ b/src/HaskellWorks/Data/Json/Cursor.hs @@ -9,15 +9,12 @@ , jsonCursorPos ) where -import Data.ByteString.Internal as BSI +import Data.ByteString.Internal as BSI import Data.String import Data.Word import Foreign.ForeignPtr -import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.FromByteString import HaskellWorks.Data.FromForeignRegion -import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson -import HaskellWorks.Data.Json.Succinct.Cursor.InterestBits import HaskellWorks.Data.Positioning import HaskellWorks.Data.RankSelect.Base.Rank0 import HaskellWorks.Data.RankSelect.Base.Rank1 @@ -25,11 +22,11 @@ import HaskellWorks.Data.RankSelect.Poppy512 import HaskellWorks.Data.TreeCursor -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.Vector.Storable as DVS -import qualified HaskellWorks.Data.BalancedParens as BP -import qualified HaskellWorks.Data.Json.Succinct.Cursor.BalancedParens as CBP +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Vector.Storable as DVS +import qualified HaskellWorks.Data.BalancedParens as BP +import qualified HaskellWorks.Data.Json.Internal.IbBp as J data JsonCursor t v w = JsonCursor { cursorText :: !t @@ -39,53 +36,31 @@ } deriving (Eq, Show) -instance (FromBlankedJson (JsonInterestBits a), FromBlankedJson (CBP.JsonBalancedParens b)) - => FromByteString (JsonCursor BS.ByteString a b) where - fromByteString bs = JsonCursor +instance FromByteString (JsonCursor BS.ByteString (DVS.Vector Word64) (BP.SimpleBalancedParens (DVS.Vector Word64))) where + fromByteString bs = JsonCursor { cursorText = bs - , interests = getJsonInterestBits (fromBlankedJson blankedJson) - , balancedParens = CBP.getJsonBalancedParens (fromBlankedJson blankedJson) + , interests = ib + , balancedParens = BP.SimpleBalancedParens bp , cursorRank = 1 } - where blankedJson :: BlankedJson - blankedJson = fromByteString bs + where J.IbBp ib bp = J.toIbBp bs -instance IsString (JsonCursor String (BitShown [Bool]) (BP.SimpleBalancedParens [Bool])) where - fromString :: String -> JsonCursor String (BitShown [Bool]) (BP.SimpleBalancedParens [Bool]) - fromString s = JsonCursor - { cursorText = s +instance FromByteString (JsonCursor BS.ByteString Poppy512 (BP.SimpleBalancedParens (DVS.Vector Word64))) where + fromByteString bs = JsonCursor + { cursorText = bs + , interests = makePoppy512 ib + , balancedParens = BP.SimpleBalancedParens bp , cursorRank = 1 - , interests = getJsonInterestBits (fromBlankedJson blankedJson) - , balancedParens = CBP.getJsonBalancedParens (fromBlankedJson blankedJson) } - where blankedJson :: BlankedJson - blankedJson = fromByteString (BSC.pack s) - -instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (BP.SimpleBalancedParens (DVS.Vector Word8))) where - fromString = fromByteString . BSC.pack - -instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (BP.SimpleBalancedParens (DVS.Vector Word16))) where - fromString = fromByteString . BSC.pack - -instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (BP.SimpleBalancedParens (DVS.Vector Word32))) where - fromString = fromByteString . BSC.pack + where J.IbBp ib bp = J.toIbBp bs -instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (BP.SimpleBalancedParens (DVS.Vector Word64))) where +instance IsString (JsonCursor BS.ByteString (DVS.Vector Word64) (BP.SimpleBalancedParens (DVS.Vector Word64))) where fromString = fromByteString . BSC.pack instance IsString (JsonCursor BS.ByteString Poppy512 (BP.SimpleBalancedParens (DVS.Vector Word64))) where fromString = fromByteString . BSC.pack -instance FromForeignRegion (JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (BP.SimpleBalancedParens (DVS.Vector Word8))) where - fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) - -instance FromForeignRegion (JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (BP.SimpleBalancedParens (DVS.Vector Word16))) where - fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) - -instance FromForeignRegion (JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (BP.SimpleBalancedParens (DVS.Vector Word32))) where - fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) - -instance FromForeignRegion (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (BP.SimpleBalancedParens (DVS.Vector Word64))) where +instance FromForeignRegion (JsonCursor BS.ByteString (DVS.Vector Word64) (BP.SimpleBalancedParens (DVS.Vector Word64))) where fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) instance FromForeignRegion (JsonCursor BS.ByteString Poppy512 (BP.SimpleBalancedParens (DVS.Vector Word64))) where diff --git a/src/HaskellWorks/Data/Json/Internal/BlankedJson.hs b/src/HaskellWorks/Data/Json/Internal/BlankedJson.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Internal/BlankedJson.hs @@ -0,0 +1,24 @@ + +module HaskellWorks.Data.Json.Internal.BlankedJson + ( BlankedJson(..) + , ToBlankedJson(..) + , toBlankedJsonTyped + ) where + +import HaskellWorks.Data.ByteString +import HaskellWorks.Data.Json.Internal.Blank + +import qualified Data.ByteString as BS + +newtype BlankedJson = BlankedJson + { unBlankedJson :: [BS.ByteString] + } deriving (Eq, Show) + +class ToBlankedJson a where + toBlankedJson :: a -> [BS.ByteString] + +instance ToBlankedJson BS.ByteString where + toBlankedJson bs = blankJson (chunkedBy 4096 bs) + +toBlankedJsonTyped :: ToBlankedJson a => a -> BlankedJson +toBlankedJsonTyped = BlankedJson . toBlankedJson diff --git a/src/HaskellWorks/Data/Json/Internal/CharLike.hs b/src/HaskellWorks/Data/Json/Internal/CharLike.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Internal/CharLike.hs @@ -0,0 +1,23 @@ +module HaskellWorks.Data.Json.Internal.CharLike where + +import Data.Word +import Data.Word8 +import HaskellWorks.Data.Json.Internal.Words + +class JsonCharLike c where + isLeadingDigit2 :: c -> Bool + isQuotDbl :: c -> Bool + isChar_t :: c -> Bool + isChar_f :: c -> Bool + isChar_n :: c -> Bool + isBraceLeft :: c -> Bool + isBracketLeft :: c -> Bool + +instance JsonCharLike Word8 where + isLeadingDigit2 = isLeadingDigit + isQuotDbl = (== _quotedbl) + isChar_t = (== _t) + isChar_f = (== _f) + isChar_n = (== _n) + isBraceLeft = (== _braceleft) + isBracketLeft = (== _bracketleft) diff --git a/src/HaskellWorks/Data/Json/Internal/Cursor/Token.hs b/src/HaskellWorks/Data/Json/Internal/Cursor/Token.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Internal/Cursor/Token.hs @@ -0,0 +1,24 @@ + +module HaskellWorks.Data.Json.Internal.Cursor.Token + ( jsonTokenAt + ) where + +import Data.ByteString.Internal as BSI +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Drop +import HaskellWorks.Data.Json.Cursor +import HaskellWorks.Data.Json.Internal.Token.Tokenize +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.RankSelect.Base.Select1 +import Prelude hiding (drop) + +import qualified Data.Attoparsec.ByteString.Char8 as ABC + +jsonTokenAt :: (Rank1 w, Select1 v, TestBit w) => JsonCursor ByteString v w -> Maybe (JsonToken String Double) +jsonTokenAt k = if balancedParens k .?. lastPositionOf (cursorRank k) + then case ABC.parse parseJsonToken (drop (toCount (jsonCursorPos k)) (cursorText k)) of + ABC.Fail {} -> error "Failed to parse token in cursor" + ABC.Partial _ -> error "Failed to parse token in cursor" + ABC.Done _ r -> Just r + else Nothing diff --git a/src/HaskellWorks/Data/Json/Internal/IbBp.hs b/src/HaskellWorks/Data/Json/Internal/IbBp.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Internal/IbBp.hs @@ -0,0 +1,24 @@ +module HaskellWorks.Data.Json.Internal.IbBp where + +import Data.Word + +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS +import qualified HaskellWorks.Data.Json.Internal.BlankedJson as J +import qualified HaskellWorks.Data.Json.Internal.ToBalancedParens64 as J +import qualified HaskellWorks.Data.Json.Internal.ToInterestBits64 as J + +data IbBp = IbBp + { ib :: DVS.Vector Word64 + , bp :: DVS.Vector Word64 + } + +class ToIbBp a where + toIbBp :: a -> IbBp + +instance ToIbBp BS.ByteString where + toIbBp bs = IbBp + { ib = J.toInterestBits64 blankedJson + , bp = J.toBalancedParens64 blankedJson + } + where blankedJson = J.toBlankedJsonTyped bs diff --git a/src/HaskellWorks/Data/Json/Internal/Index.hs b/src/HaskellWorks/Data/Json/Internal/Index.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Internal/Index.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Internal.Index where + +import Control.Arrow +import Control.Monad +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Drop +import HaskellWorks.Data.Json.Cursor +import HaskellWorks.Data.Json.DecodeError +import HaskellWorks.Data.Json.Internal.CharLike +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.RankSelect.Base.Rank0 +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.RankSelect.Base.Select1 +import HaskellWorks.Data.TreeCursor +import HaskellWorks.Data.Uncons +import Prelude hiding (drop) + +import qualified Data.ByteString as BS +import qualified Data.List as L +import qualified HaskellWorks.Data.BalancedParens as BP + +data JsonIndex + = JsonIndexString BS.ByteString + | JsonIndexNumber BS.ByteString + | JsonIndexObject [(BS.ByteString, JsonIndex)] + | JsonIndexArray [JsonIndex] + | JsonIndexBool Bool + | JsonIndexNull + deriving (Eq, Show) + +class JsonIndexAt a where + jsonIndexAt :: a -> Either DecodeError JsonIndex + +instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => JsonIndexAt (JsonCursor BS.ByteString v w) where + jsonIndexAt k = case uncons remainder of + Just (!c, _) | isLeadingDigit2 c -> Right (JsonIndexNumber remainder) + Just (!c, _) | isQuotDbl c -> Right (JsonIndexString remainder) + Just (!c, _) | isChar_t c -> Right (JsonIndexBool True) + Just (!c, _) | isChar_f c -> Right (JsonIndexBool False) + Just (!c, _) | isChar_n c -> Right JsonIndexNull + Just (!c, _) | isBraceLeft c -> JsonIndexObject <$> mapValuesFrom (firstChild k) + Just (!c, _) | isBracketLeft c -> JsonIndexArray <$> arrayValuesFrom (firstChild k) + Just _ -> Left (DecodeError "Invalid Json Type") + Nothing -> Left (DecodeError "End of data" ) + where ik = interests k + bpk = balancedParens k + p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k))) + remainder = drop (toCount p) (cursorText k) + arrayValuesFrom j = sequence (L.unfoldr (fmap (jsonIndexAt &&& nextSibling)) j) + mapValuesFrom j = (pairwise >=> asField) <$> arrayValuesFrom j + pairwise (a:b:rs) = (a, b) : pairwise rs + pairwise _ = [] + asField (a, b) = case a of + JsonIndexString s -> [(s, b)] + _ -> [] diff --git a/src/HaskellWorks/Data/Json/Internal/MakeIndex.hs b/src/HaskellWorks/Data/Json/Internal/MakeIndex.hs --- a/src/HaskellWorks/Data/Json/Internal/MakeIndex.hs +++ b/src/HaskellWorks/Data/Json/Internal/MakeIndex.hs @@ -5,7 +5,6 @@ ( blankedJsonToInterestBits , byteStringToBits , blankedJsonToBalancedParens - , blankedJsonToBalancedParens2 , compressWordAsBit , interestingWord8s ) where @@ -57,29 +56,6 @@ , BS.drop 8 ds ) -blankedJsonToBalancedParens :: [BS.ByteString] -> [Bool] -blankedJsonToBalancedParens (as) = case as of - (bs:bss) -> blankedJsonToBalancedParens' bs bss [] - [] -> [] - -blankedJsonToBalancedParens' :: BS.ByteString -> [BS.ByteString] -> ([Bool] -> [Bool]) -blankedJsonToBalancedParens' bs = case BS.uncons bs of - Just (c, cs) -> do - let t = case c of - d | d == _braceleft -> (True:) - d | d == _braceright -> (False:) - d | d == _bracketleft -> (True:) - d | d == _bracketright -> (False:) - d | d == _parenleft -> (True:) - d | d == _parenright -> (False:) - d | d == _t -> (True:) . (False:) - d | d == _f -> (True:) . (False:) - d | d == _1 -> (True:) . (False:) - d | d == _n -> (True:) . (False:) - _ -> id - (t .) . blankedJsonToBalancedParens' cs - Nothing -> const id - repartitionMod8 :: BS.ByteString -> BS.ByteString -> (BS.ByteString, BS.ByteString) repartitionMod8 aBS bBS = (BS.take cLen abBS, BS.drop cLen abBS) where abBS = BS.concat [aBS, bBS] @@ -105,11 +81,11 @@ , BS.drop 8 xs ) -blankedJsonToBalancedParens2 :: [BS.ByteString] -> [BS.ByteString] -blankedJsonToBalancedParens2 as = case as of +blankedJsonToBalancedParens :: [BS.ByteString] -> [BS.ByteString] +blankedJsonToBalancedParens as = case as of (bs:bss) -> let (cs, _) = BS.unfoldrN (BS.length bs * 2) gen (Nothing, bs) in - cs:blankedJsonToBalancedParens2 bss + cs:blankedJsonToBalancedParens bss [] -> [] where gen :: (Maybe Bool, ByteString) -> Maybe (Word8, (Maybe Bool, ByteString)) gen (Just True , bs) = Just (0xFF, (Nothing, bs)) diff --git a/src/HaskellWorks/Data/Json/Internal/PartialIndex.hs b/src/HaskellWorks/Data/Json/Internal/PartialIndex.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Internal/PartialIndex.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Json.Internal.PartialIndex where + +import Control.Arrow +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Drop +import HaskellWorks.Data.Json.Cursor +import HaskellWorks.Data.Json.Internal.CharLike +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.RankSelect.Base.Rank0 +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.RankSelect.Base.Select1 +import HaskellWorks.Data.TreeCursor +import HaskellWorks.Data.Uncons +import Prelude hiding (drop) + +import qualified Data.ByteString as BS +import qualified Data.List as L +import qualified HaskellWorks.Data.BalancedParens as BP + +data JsonPartialIndex + = JsonPartialIndexString BS.ByteString + | JsonPartialIndexNumber BS.ByteString + | JsonPartialIndexObject [(BS.ByteString, JsonPartialIndex)] + | JsonPartialIndexArray [JsonPartialIndex] + | JsonPartialIndexBool Bool + | JsonPartialIndexNull + | JsonPartialIndexError String + deriving (Eq, Show) + +class JsonPartialIndexAt a where + jsonPartialIndexAt :: a -> JsonPartialIndex + +instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => JsonPartialIndexAt (JsonCursor BS.ByteString v w) where + jsonPartialIndexAt k = case uncons remainder of + Just (!c, _) | isLeadingDigit2 c -> JsonPartialIndexNumber remainder + Just (!c, _) | isQuotDbl c -> JsonPartialIndexString remainder + Just (!c, _) | isChar_t c -> JsonPartialIndexBool True + Just (!c, _) | isChar_f c -> JsonPartialIndexBool False + Just (!c, _) | isChar_n c -> JsonPartialIndexNull + Just (!c, _) | isBraceLeft c -> JsonPartialIndexObject (mapValuesFrom (firstChild k)) + Just (!c, _) | isBracketLeft c -> JsonPartialIndexArray (arrayValuesFrom (firstChild k)) + Just _ -> JsonPartialIndexError "Invalid Json Type" + Nothing -> JsonPartialIndexError "End of data" + where ik = interests k + bpk = balancedParens k + p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k))) + remainder = drop (toCount p) (cursorText k) + arrayValuesFrom :: Maybe (JsonCursor BS.ByteString v w) -> [JsonPartialIndex] + arrayValuesFrom = L.unfoldr (fmap (jsonPartialIndexAt &&& nextSibling)) + mapValuesFrom j = pairwise (arrayValuesFrom j) >>= asField + pairwise (a:b:rs) = (a, b) : pairwise rs + pairwise _ = [] + asField (a, b) = case a of + JsonPartialIndexString s -> [(s, b)] + _ -> [] diff --git a/src/HaskellWorks/Data/Json/Internal/ToBalancedParens64.hs b/src/HaskellWorks/Data/Json/Internal/ToBalancedParens64.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Internal/ToBalancedParens64.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Internal.ToBalancedParens64 + ( ToBalancedParens64(..) + ) where + +import Control.Applicative +import Data.Word +import HaskellWorks.Data.Json.Internal.MakeIndex + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Vector.Storable as DVS +import qualified HaskellWorks.Data.Json.Internal.BlankedJson as J + +genBitWordsForever :: LBS.ByteString -> Maybe (Word8, LBS.ByteString) +genBitWordsForever bs = LBS.uncons bs <|> Just (0, bs) +{-# INLINE genBitWordsForever #-} + +class ToBalancedParens64 a where + toBalancedParens64 :: a -> DVS.Vector Word64 + +instance ToBalancedParens64 J.BlankedJson where + toBalancedParens64 (J.BlankedJson bj) = DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever bpBS) + where bpBS = LBS.fromChunks (compressWordAsBit (blankedJsonToBalancedParens bj)) + newLen = fromIntegral ((LBS.length bpBS + 7) `div` 8 * 8) diff --git a/src/HaskellWorks/Data/Json/Internal/ToInterestBits64.hs b/src/HaskellWorks/Data/Json/Internal/ToInterestBits64.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Internal/ToInterestBits64.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Internal.ToInterestBits64 + ( ToInterestBits64(..) + ) where + +import Control.Applicative +import Data.ByteString.Internal +import Data.Word +import HaskellWorks.Data.Json.Internal.MakeIndex + +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS +import qualified HaskellWorks.Data.Json.Internal.BlankedJson as J + +class ToInterestBits64 a where + toInterestBits64 :: a -> DVS.Vector Word64 + +instance ToInterestBits64 J.BlankedJson where + toInterestBits64 bj = DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS) + where interestBS = blankedJsonBssToInterestBitsBs (J.unBlankedJson bj) + newLen = (BS.length interestBS + 7) `div` 8 * 8 + +blankedJsonBssToInterestBitsBs :: [ByteString] -> ByteString +blankedJsonBssToInterestBitsBs bss = BS.concat $ blankedJsonToInterestBits bss + +genInterestForever :: ByteString -> Maybe (Word8, ByteString) +genInterestForever bs = BS.uncons bs <|> Just (0, bs) diff --git a/src/HaskellWorks/Data/Json/Internal/Token.hs b/src/HaskellWorks/Data/Json/Internal/Token.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Internal/Token.hs @@ -0,0 +1,5 @@ +module HaskellWorks.Data.Json.Internal.Token + ( module X + ) where + +import HaskellWorks.Data.Json.Internal.Token.Tokenize as X diff --git a/src/HaskellWorks/Data/Json/Internal/Token/Tokenize.hs b/src/HaskellWorks/Data/Json/Internal/Token/Tokenize.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Internal/Token/Tokenize.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module HaskellWorks.Data.Json.Internal.Token.Tokenize + ( IsChar(..) + , JsonToken(..) + , ParseJson(..) + ) where + +import Control.Applicative +import Data.Bits +import Data.Char +import Data.Word +import Data.Word8 +import HaskellWorks.Data.Char.IsChar +import HaskellWorks.Data.Json.Internal.Token.Types +import HaskellWorks.Data.Parser (()) + +import qualified Data.Attoparsec.ByteString.Char8 as BC +import qualified Data.Attoparsec.Combinator as AC +import qualified Data.Attoparsec.Types as T +import qualified Data.ByteString as BS +import qualified HaskellWorks.Data.Parser as P + +hexDigitNumeric :: P.Parser t u => T.Parser t Int +hexDigitNumeric = do + c <- P.satisfyChar (\c -> '0' <= c && c <= '9') + return $ ord c - ord '0' + +hexDigitAlphaLower :: P.Parser t u => T.Parser t Int +hexDigitAlphaLower = do + c <- P.satisfyChar (\c -> 'a' <= c && c <= 'z') + return $ ord c - ord 'a' + 10 + +hexDigitAlphaUpper :: P.Parser t u => T.Parser t Int +hexDigitAlphaUpper = do + c <- P.satisfyChar (\c -> 'A' <= c && c <= 'Z') + return $ ord c - ord 'A' + 10 + +hexDigit :: P.Parser t u => T.Parser t Int +hexDigit = hexDigitNumeric <|> hexDigitAlphaLower <|> hexDigitAlphaUpper + +class ParseJson t s d where + parseJsonTokenString :: T.Parser t (JsonToken s d) + parseJsonToken :: T.Parser t (JsonToken s d) + parseJsonTokenBraceL :: T.Parser t (JsonToken s d) + parseJsonTokenBraceR :: T.Parser t (JsonToken s d) + parseJsonTokenBracketL :: T.Parser t (JsonToken s d) + parseJsonTokenBracketR :: T.Parser t (JsonToken s d) + parseJsonTokenComma :: T.Parser t (JsonToken s d) + parseJsonTokenColon :: T.Parser t (JsonToken s d) + parseJsonTokenWhitespace :: T.Parser t (JsonToken s d) + parseJsonTokenNull :: T.Parser t (JsonToken s d) + parseJsonTokenBoolean :: T.Parser t (JsonToken s d) + parseJsonTokenDouble :: T.Parser t (JsonToken s d) + + parseJsonToken = + parseJsonTokenString <|> + parseJsonTokenBraceL <|> + parseJsonTokenBraceR <|> + parseJsonTokenBracketL <|> + parseJsonTokenBracketR <|> + parseJsonTokenComma <|> + parseJsonTokenColon <|> + parseJsonTokenWhitespace <|> + parseJsonTokenNull <|> + parseJsonTokenBoolean <|> + parseJsonTokenDouble + +instance ParseJson BS.ByteString String Double where + parseJsonTokenBraceL = P.string "{" >> return JsonTokenBraceL + parseJsonTokenBraceR = P.string "}" >> return JsonTokenBraceR + parseJsonTokenBracketL = P.string "[" >> return JsonTokenBracketL + parseJsonTokenBracketR = P.string "]" >> return JsonTokenBracketR + parseJsonTokenComma = P.string "," >> return JsonTokenComma + parseJsonTokenColon = P.string ":" >> return JsonTokenColon + parseJsonTokenNull = P.string "null" >> return JsonTokenNull + parseJsonTokenDouble = JsonTokenNumber <$> P.rational + + parseJsonTokenString = do + _ <- P.string "\"" + value <- many (verbatimChar <|> escapedChar <|> escapedCode) + _ <- P.string "\"" + return $ JsonTokenString value + where + verbatimChar = P.satisfyChar (BC.notInClass "\"\\") "invalid string character" + escapedChar = do + _ <- P.string "\\" + ( P.char '"' >> return '"' ) <|> + ( P.char 'b' >> return '\b' ) <|> + ( P.char 'n' >> return '\n' ) <|> + ( P.char 'f' >> return '\f' ) <|> + ( P.char 'r' >> return '\r' ) <|> + ( P.char 't' >> return '\t' ) <|> + ( P.char '\\' >> return '\\' ) <|> + ( P.char '\'' >> return '\'' ) <|> + ( P.char '/' >> return '/' ) + escapedCode = do + _ <- P.string "\\u" + a <- hexDigit + b <- hexDigit + c <- hexDigit + d <- hexDigit + return $ chr $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d + + parseJsonTokenWhitespace = do + _ <- AC.many1' $ BC.choice [P.string " ", P.string "\t", P.string "\n", P.string "\r"] + return JsonTokenWhitespace + + parseJsonTokenBoolean = true <|> false + where true = P.string "true" >> return (JsonTokenBoolean True) + false = P.string "false" >> return (JsonTokenBoolean False) + +instance ParseJson BS.ByteString BS.ByteString Double where + parseJsonTokenBraceL = P.string "{" >> return JsonTokenBraceL + parseJsonTokenBraceR = P.string "}" >> return JsonTokenBraceR + parseJsonTokenBracketL = P.string "[" >> return JsonTokenBracketL + parseJsonTokenBracketR = P.string "]" >> return JsonTokenBracketR + parseJsonTokenComma = P.string "," >> return JsonTokenComma + parseJsonTokenColon = P.string ":" >> return JsonTokenColon + parseJsonTokenNull = P.string "null" >> return JsonTokenNull + parseJsonTokenDouble = JsonTokenNumber <$> P.rational + + parseJsonTokenString = do + _ <- P.string "\"" + value <- many (verbatimChar <|> escapedChar <|> escapedCode) + _ <- P.string "\"" + return $ JsonTokenString $ BS.pack value + where + word :: Word8 -> T.Parser BS.ByteString Word8 + word w = P.satisfy (== w) + verbatimChar :: T.Parser BS.ByteString Word8 + verbatimChar = P.satisfy (\w -> w /= _quotedbl && w /= _backslash) -- "invalid string character" + escapedChar :: T.Parser BS.ByteString Word8 + escapedChar = do + _ <- P.string "\\" + ( word _quotedbl >> return _quotedbl ) <|> + ( word _b >> return 0x08 ) <|> + ( word _n >> return _lf ) <|> + ( word _f >> return _np ) <|> + ( word _r >> return _cr ) <|> + ( word _t >> return _tab ) <|> + ( word _backslash >> return _backslash ) <|> + ( word _quotesingle >> return _quotesingle ) <|> + ( word _slash >> return _slash ) + escapedCode :: T.Parser BS.ByteString Word8 + escapedCode = do + _ <- P.string "\\u" + a <- hexDigit + b <- hexDigit + c <- hexDigit + d <- hexDigit + return $ fromIntegral $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d + + parseJsonTokenWhitespace = do + _ <- AC.many1' $ BC.choice [P.string " ", P.string "\t", P.string "\n", P.string "\r"] + return JsonTokenWhitespace + + parseJsonTokenBoolean = true <|> false + where + true = P.string "true" >> return (JsonTokenBoolean True) + false = P.string "false" >> return (JsonTokenBoolean False) diff --git a/src/HaskellWorks/Data/Json/Internal/Token/Types.hs b/src/HaskellWorks/Data/Json/Internal/Token/Types.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Internal/Token/Types.hs @@ -0,0 +1,15 @@ +module HaskellWorks.Data.Json.Internal.Token.Types (JsonToken(..)) where + +data JsonToken s d + = JsonTokenBraceL + | JsonTokenBraceR + | JsonTokenBracketL + | JsonTokenBracketR + | JsonTokenComma + | JsonTokenColon + | JsonTokenWhitespace + | JsonTokenString s + | JsonTokenBoolean Bool + | JsonTokenNumber d + | JsonTokenNull + deriving (Eq, Show) diff --git a/src/HaskellWorks/Data/Json/Internal/Value.hs b/src/HaskellWorks/Data/Json/Internal/Value.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Internal/Value.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HaskellWorks.Data.Json.Internal.Value where + +import Control.Applicative +import Data.Bits +import Data.Char +import Data.String +import HaskellWorks.Data.Parser as P + +import qualified Data.Attoparsec.ByteString.Char8 as ABC +import qualified Data.Attoparsec.Types as T + +parseHexDigitNumeric :: P.Parser t u => T.Parser t Int +parseHexDigitNumeric = do + c <- satisfyChar (\c -> '0' <= c && c <= '9') + return $ ord c - ord '0' + +parseHexDigitAlphaLower :: P.Parser t u => T.Parser t Int +parseHexDigitAlphaLower = do + c <- satisfyChar (\c -> 'a' <= c && c <= 'z') + return $ ord c - ord 'a' + 10 + +parseHexDigitAlphaUpper :: P.Parser t u => T.Parser t Int +parseHexDigitAlphaUpper = do + c <- satisfyChar (\c -> 'A' <= c && c <= 'Z') + return $ ord c - ord 'A' + 10 + +parseHexDigit :: P.Parser t u => T.Parser t Int +parseHexDigit = parseHexDigitNumeric <|> parseHexDigitAlphaLower <|> parseHexDigitAlphaUpper + +parseJsonString :: (P.Parser t u, IsString t) => T.Parser t String +parseJsonString = do + _ <- string "\"" + value <- many (verbatimChar <|> escapedChar <|> escapedCode) + _ <- string "\"" + return value + where + verbatimChar = satisfyChar (ABC.notInClass "\"\\") "invalid string character" + escapedChar = do + _ <- string "\\" + ( char '"' >> return '"' ) <|> + ( char 'b' >> return '\b' ) <|> + ( char 'n' >> return '\n' ) <|> + ( char 'f' >> return '\f' ) <|> + ( char 'r' >> return '\r' ) <|> + ( char 't' >> return '\t' ) <|> + ( char '\\' >> return '\\' ) <|> + ( char '\'' >> return '\'' ) <|> + ( char '/' >> return '/' ) + escapedCode = do + _ <- string "\\u" + a <- parseHexDigit + b <- parseHexDigit + c <- parseHexDigit + d <- parseHexDigit + return $ chr $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d diff --git a/src/HaskellWorks/Data/Json/Internal/Words.hs b/src/HaskellWorks/Data/Json/Internal/Words.hs --- a/src/HaskellWorks/Data/Json/Internal/Words.hs +++ b/src/HaskellWorks/Data/Json/Internal/Words.hs @@ -11,3 +11,6 @@ isAlphabetic :: Word8 -> Bool isAlphabetic w = (w >= _A && w <= _Z) || (w >= _a && w <= _z) + +wIsJsonNumberDigit :: Word8 -> Bool +wIsJsonNumberDigit w = (w >= _0 && w <= _9) || w == _hyphen diff --git a/src/HaskellWorks/Data/Json/LightJson.hs b/src/HaskellWorks/Data/Json/LightJson.hs --- a/src/HaskellWorks/Data/Json/LightJson.hs +++ b/src/HaskellWorks/Data/Json/LightJson.hs @@ -16,8 +16,8 @@ import HaskellWorks.Data.Bits.BitWise import HaskellWorks.Data.Drop import HaskellWorks.Data.Entry -import HaskellWorks.Data.Json.CharLike import HaskellWorks.Data.Json.Cursor +import HaskellWorks.Data.Json.Internal.CharLike import HaskellWorks.Data.Json.Internal.Words import HaskellWorks.Data.Micro import HaskellWorks.Data.Mini diff --git a/src/HaskellWorks/Data/Json/Load.hs b/src/HaskellWorks/Data/Json/Load.hs --- a/src/HaskellWorks/Data/Json/Load.hs +++ b/src/HaskellWorks/Data/Json/Load.hs @@ -25,9 +25,9 @@ import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.Json.Cursor import HaskellWorks.Data.Json.DecodeError +import HaskellWorks.Data.Json.Internal.Index +import HaskellWorks.Data.Json.Internal.PartialIndex import HaskellWorks.Data.Json.PartialValue -import HaskellWorks.Data.Json.Succinct.Index -import HaskellWorks.Data.Json.Succinct.PartialIndex import HaskellWorks.Data.Json.Value import HaskellWorks.Data.RankSelect.CsPoppy import HaskellWorks.Data.RankSelect.Poppy512 @@ -50,11 +50,11 @@ writeVector :: forall a. Storable a => FilePath -> DVS.Vector a -> IO () writeVector fp v = withFile fp WriteMode $ \h -> hPutVector h v -readJson :: String -> IO (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) +readJson :: String -> IO (JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64))) readJson path = do bs <- loadByteString path putStrLn "Read file" - let !cursor = fromByteString bs :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + let !cursor = fromByteString bs :: JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64)) putStrLn "Created cursor" return cursor @@ -111,7 +111,7 @@ indexJson :: String -> IO () indexJson filename = do - JsonCursor _ (BitShown ib) (SimpleBalancedParens bp) _ <- readJson filename + JsonCursor _ ib (SimpleBalancedParens bp) _ <- readJson filename let wib = DVS.unsafeCast ib :: DVS.Vector Word8 let wbp = DVS.unsafeCast bp :: DVS.Vector Word8 writeVector (filename ++ ".ib") wib diff --git a/src/HaskellWorks/Data/Json/LoadCursor.hs b/src/HaskellWorks/Data/Json/LoadCursor.hs --- a/src/HaskellWorks/Data/Json/LoadCursor.hs +++ b/src/HaskellWorks/Data/Json/LoadCursor.hs @@ -18,12 +18,11 @@ import Foreign.Ptr import Foreign.Storable import HaskellWorks.Data.BalancedParens.Simple -import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.FromByteString import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.Json.Cursor import HaskellWorks.Data.Json.DecodeError -import HaskellWorks.Data.Json.Succinct.Index +import HaskellWorks.Data.Json.Internal.Index import HaskellWorks.Data.Json.Value import HaskellWorks.Data.RankSelect.CsPoppy import HaskellWorks.Data.RankSelect.Poppy512 @@ -46,11 +45,11 @@ writeVector :: forall a. Storable a => FilePath -> DVS.Vector a -> IO () writeVector fp v = withFile fp WriteMode $ \h -> hPutVector h v -readJson :: String -> IO (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) +readJson :: String -> IO (JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64))) readJson path = do bs <- BS.readFile path putStrLn "Read file" - let !cursor = fromByteString bs :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + let !cursor = fromByteString bs :: JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64)) putStrLn "Created cursor" return cursor @@ -76,10 +75,10 @@ let jsonBp = fromForeignRegion jsonBpFr :: DVS.Vector Word64 return (jsonBS, jsonIb, jsonBp) -loadJsonWithIndex :: String -> IO (JsonCursor BSI.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) +loadJsonWithIndex :: String -> IO (JsonCursor BSI.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64))) loadJsonWithIndex filename = do (jsonBS, jsonIb, jsonBp) <- loadJsonRawWithIndex filename - let cursor = JsonCursor jsonBS (BitShown jsonIb) (SimpleBalancedParens jsonBp) 1 + let cursor = JsonCursor jsonBS jsonIb (SimpleBalancedParens jsonBp) 1 return cursor loadJsonWithPoppy512Index :: String -> IO (JsonCursor BSI.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) @@ -103,7 +102,7 @@ indexJsonCursor :: String -> IO () indexJsonCursor filename = do - JsonCursor _ (BitShown ib) (SimpleBalancedParens bp) _ <- readJson filename + JsonCursor _ ib (SimpleBalancedParens bp) _ <- readJson filename let wib = DVS.unsafeCast ib :: DVS.Vector Word8 let wbp = DVS.unsafeCast bp :: DVS.Vector Word8 writeVector (filename ++ ".ib") wib diff --git a/src/HaskellWorks/Data/Json/PartialValue.hs b/src/HaskellWorks/Data/Json/PartialValue.hs --- a/src/HaskellWorks/Data/Json/PartialValue.hs +++ b/src/HaskellWorks/Data/Json/PartialValue.hs @@ -25,8 +25,8 @@ import HaskellWorks.Data.Bits.BitWise import HaskellWorks.Data.Entry import HaskellWorks.Data.Json.Cursor -import HaskellWorks.Data.Json.Succinct.PartialIndex -import HaskellWorks.Data.Json.Value.Internal +import HaskellWorks.Data.Json.Internal.PartialIndex +import HaskellWorks.Data.Json.Internal.Value import HaskellWorks.Data.Micro import HaskellWorks.Data.Mini import HaskellWorks.Data.MQuery diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module HaskellWorks.Data.Json.Succinct.Cursor.BalancedParens - ( JsonBalancedParens(..) - , getJsonBalancedParens - ) where - -import Control.Applicative -import Data.Word -import HaskellWorks.Data.BalancedParens as BP -import HaskellWorks.Data.Json.Internal.MakeIndex -import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson - -import qualified Data.ByteString as BS -import qualified Data.Vector.Storable as DVS - -newtype JsonBalancedParens a = JsonBalancedParens a - -getJsonBalancedParens :: JsonBalancedParens a -> a -getJsonBalancedParens (JsonBalancedParens a) = a - -genBitWordsForever :: BS.ByteString -> Maybe (Word8, BS.ByteString) -genBitWordsForever bs = BS.uncons bs <|> Just (0, bs) -{-# INLINE genBitWordsForever #-} - -instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens [Bool])) where - fromBlankedJson (BlankedJson bj) = JsonBalancedParens (SimpleBalancedParens (blankedJsonToBalancedParens bj)) - -instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word8))) where - fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever bpBS))) - where bpBS = BS.concat ((compressWordAsBit . blankedJsonToBalancedParens2) (getBlankedJson bj)) - newLen = (BS.length bpBS + 7) `div` 8 * 8 - -instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word16))) where - fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever bpBS))) - where bpBS = BS.concat ((compressWordAsBit . blankedJsonToBalancedParens2) (getBlankedJson bj)) - newLen = (BS.length bpBS + 7) `div` 8 * 8 - -instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word32))) where - fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever bpBS))) - where bpBS = BS.concat ((compressWordAsBit . blankedJsonToBalancedParens2) (getBlankedJson bj)) - newLen = (BS.length bpBS + 7) `div` 8 * 8 - -instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word64))) where - fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever bpBS))) - where bpBS = BS.concat ((compressWordAsBit . blankedJsonToBalancedParens2) (getBlankedJson bj)) - newLen = (BS.length bpBS + 7) `div` 8 * 8 diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs +++ /dev/null @@ -1,23 +0,0 @@ - -module HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson - ( BlankedJson(..) - , FromBlankedJson(..) - , getBlankedJson - ) where - -import HaskellWorks.Data.ByteString -import HaskellWorks.Data.FromByteString -import HaskellWorks.Data.Json.Internal.Blank - -import qualified Data.ByteString as BS - -newtype BlankedJson = BlankedJson [BS.ByteString] deriving (Eq, Show) - -getBlankedJson :: BlankedJson -> [BS.ByteString] -getBlankedJson (BlankedJson bs) = bs - -class FromBlankedJson a where - fromBlankedJson :: BlankedJson -> a - -instance FromByteString BlankedJson where - fromByteString bs = BlankedJson (blankJson (chunkedBy 4064 bs)) diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module HaskellWorks.Data.Json.Succinct.Cursor.InterestBits - ( JsonInterestBits(..) - , getJsonInterestBits - ) where - -import Control.Applicative -import Data.ByteString.Internal -import Data.Word -import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.FromByteString -import HaskellWorks.Data.Json.Internal.MakeIndex -import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson -import HaskellWorks.Data.RankSelect.Poppy512 - -import qualified Data.ByteString as BS -import qualified Data.Vector.Storable as DVS - -newtype JsonInterestBits a = JsonInterestBits a - -getJsonInterestBits :: JsonInterestBits a -> a -getJsonInterestBits (JsonInterestBits a) = a - -blankedJsonBssToInterestBitsBs :: [ByteString] -> ByteString -blankedJsonBssToInterestBitsBs bss = BS.concat $ blankedJsonToInterestBits bss - -genInterest :: ByteString -> Maybe (Word8, ByteString) -genInterest = BS.uncons - -genInterestForever :: ByteString -> Maybe (Word8, ByteString) -genInterestForever bs = BS.uncons bs <|> Just (0, bs) - -instance FromBlankedJson (JsonInterestBits (BitShown [Bool])) where - fromBlankedJson = JsonInterestBits . fromByteString . BS.concat . blankedJsonToInterestBits . getBlankedJson - -instance FromBlankedJson (JsonInterestBits (BitShown BS.ByteString)) where - fromBlankedJson = JsonInterestBits . BitShown . BS.unfoldr genInterest . blankedJsonBssToInterestBitsBs . getBlankedJson - -instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word8))) where - fromBlankedJson = JsonInterestBits . BitShown . DVS.unfoldr genInterest . blankedJsonBssToInterestBitsBs . getBlankedJson - -instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word16))) where - fromBlankedJson bj = JsonInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) - where interestBS = blankedJsonBssToInterestBitsBs (getBlankedJson bj) - newLen = (BS.length interestBS + 1) `div` 2 * 2 - -instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word32))) where - fromBlankedJson bj = JsonInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) - where interestBS = blankedJsonBssToInterestBitsBs (getBlankedJson bj) - newLen = (BS.length interestBS + 3) `div` 4 * 4 - -instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word64))) where - fromBlankedJson bj = JsonInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) - where interestBS = blankedJsonBssToInterestBitsBs (getBlankedJson bj) - newLen = (BS.length interestBS + 7) `div` 8 * 8 - -instance FromBlankedJson (JsonInterestBits Poppy512) where - fromBlankedJson = JsonInterestBits . makePoppy512 . bitShown . getJsonInterestBits . fromBlankedJson diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/Token.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/Token.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Json/Succinct/Cursor/Token.hs +++ /dev/null @@ -1,24 +0,0 @@ - -module HaskellWorks.Data.Json.Succinct.Cursor.Token - ( jsonTokenAt - ) where - -import Data.ByteString.Internal as BSI -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.Drop -import HaskellWorks.Data.Json.Cursor -import HaskellWorks.Data.Json.Token.Tokenize -import HaskellWorks.Data.Positioning -import HaskellWorks.Data.RankSelect.Base.Rank1 -import HaskellWorks.Data.RankSelect.Base.Select1 -import Prelude hiding (drop) - -import qualified Data.Attoparsec.ByteString.Char8 as ABC - -jsonTokenAt :: (Rank1 w, Select1 v, TestBit w) => JsonCursor ByteString v w -> Maybe (JsonToken String Double) -jsonTokenAt k = if balancedParens k .?. lastPositionOf (cursorRank k) - then case ABC.parse parseJsonToken (drop (toCount (jsonCursorPos k)) (cursorText k)) of - ABC.Fail {} -> error "Failed to parse token in cursor" - ABC.Partial _ -> error "Failed to parse token in cursor" - ABC.Done _ r -> Just r - else Nothing diff --git a/src/HaskellWorks/Data/Json/Succinct/Index.hs b/src/HaskellWorks/Data/Json/Succinct/Index.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Json/Succinct/Index.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module HaskellWorks.Data.Json.Succinct.Index where - -import Control.Arrow -import Control.Monad -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.Drop -import HaskellWorks.Data.Json.CharLike -import HaskellWorks.Data.Json.Cursor -import HaskellWorks.Data.Json.DecodeError -import HaskellWorks.Data.Positioning -import HaskellWorks.Data.RankSelect.Base.Rank0 -import HaskellWorks.Data.RankSelect.Base.Rank1 -import HaskellWorks.Data.RankSelect.Base.Select1 -import HaskellWorks.Data.TreeCursor -import HaskellWorks.Data.Uncons -import Prelude hiding (drop) - -import qualified Data.ByteString as BS -import qualified Data.List as L -import qualified HaskellWorks.Data.BalancedParens as BP - -data JsonIndex - = JsonIndexString BS.ByteString - | JsonIndexNumber BS.ByteString - | JsonIndexObject [(BS.ByteString, JsonIndex)] - | JsonIndexArray [JsonIndex] - | JsonIndexBool Bool - | JsonIndexNull - deriving (Eq, Show) - -class JsonIndexAt a where - jsonIndexAt :: a -> Either DecodeError JsonIndex - -instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => JsonIndexAt (JsonCursor BS.ByteString v w) where - jsonIndexAt k = case uncons remainder of - Just (!c, _) | isLeadingDigit2 c -> Right (JsonIndexNumber remainder) - Just (!c, _) | isQuotDbl c -> Right (JsonIndexString remainder) - Just (!c, _) | isChar_t c -> Right (JsonIndexBool True) - Just (!c, _) | isChar_f c -> Right (JsonIndexBool False) - Just (!c, _) | isChar_n c -> Right JsonIndexNull - Just (!c, _) | isBraceLeft c -> JsonIndexObject <$> mapValuesFrom (firstChild k) - Just (!c, _) | isBracketLeft c -> JsonIndexArray <$> arrayValuesFrom (firstChild k) - Just _ -> Left (DecodeError "Invalid Json Type") - Nothing -> Left (DecodeError "End of data" ) - where ik = interests k - bpk = balancedParens k - p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k))) - remainder = drop (toCount p) (cursorText k) - arrayValuesFrom j = sequence (L.unfoldr (fmap (jsonIndexAt &&& nextSibling)) j) - mapValuesFrom j = (pairwise >=> asField) <$> arrayValuesFrom j - pairwise (a:b:rs) = (a, b) : pairwise rs - pairwise _ = [] - asField (a, b) = case a of - JsonIndexString s -> [(s, b)] - _ -> [] diff --git a/src/HaskellWorks/Data/Json/Succinct/PartialIndex.hs b/src/HaskellWorks/Data/Json/Succinct/PartialIndex.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Json/Succinct/PartialIndex.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module HaskellWorks.Data.Json.Succinct.PartialIndex where - -import Control.Arrow -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.Drop -import HaskellWorks.Data.Json.CharLike -import HaskellWorks.Data.Json.Cursor -import HaskellWorks.Data.Positioning -import HaskellWorks.Data.RankSelect.Base.Rank0 -import HaskellWorks.Data.RankSelect.Base.Rank1 -import HaskellWorks.Data.RankSelect.Base.Select1 -import HaskellWorks.Data.TreeCursor -import HaskellWorks.Data.Uncons -import Prelude hiding (drop) - -import qualified Data.ByteString as BS -import qualified Data.List as L -import qualified HaskellWorks.Data.BalancedParens as BP - -data JsonPartialIndex - = JsonPartialIndexString BS.ByteString - | JsonPartialIndexNumber BS.ByteString - | JsonPartialIndexObject [(BS.ByteString, JsonPartialIndex)] - | JsonPartialIndexArray [JsonPartialIndex] - | JsonPartialIndexBool Bool - | JsonPartialIndexNull - | JsonPartialIndexError String - deriving (Eq, Show) - -class JsonPartialIndexAt a where - jsonPartialIndexAt :: a -> JsonPartialIndex - -instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => JsonPartialIndexAt (JsonCursor BS.ByteString v w) where - jsonPartialIndexAt k = case uncons remainder of - Just (!c, _) | isLeadingDigit2 c -> JsonPartialIndexNumber remainder - Just (!c, _) | isQuotDbl c -> JsonPartialIndexString remainder - Just (!c, _) | isChar_t c -> JsonPartialIndexBool True - Just (!c, _) | isChar_f c -> JsonPartialIndexBool False - Just (!c, _) | isChar_n c -> JsonPartialIndexNull - Just (!c, _) | isBraceLeft c -> JsonPartialIndexObject (mapValuesFrom (firstChild k)) - Just (!c, _) | isBracketLeft c -> JsonPartialIndexArray (arrayValuesFrom (firstChild k)) - Just _ -> JsonPartialIndexError "Invalid Json Type" - Nothing -> JsonPartialIndexError "End of data" - where ik = interests k - bpk = balancedParens k - p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k))) - remainder = drop (toCount p) (cursorText k) - arrayValuesFrom :: Maybe (JsonCursor BS.ByteString v w) -> [JsonPartialIndex] - arrayValuesFrom = L.unfoldr (fmap (jsonPartialIndexAt &&& nextSibling)) - mapValuesFrom j = pairwise (arrayValuesFrom j) >>= asField - pairwise (a:b:rs) = (a, b) : pairwise rs - pairwise _ = [] - asField (a, b) = case a of - JsonPartialIndexString s -> [(s, b)] - _ -> [] diff --git a/src/HaskellWorks/Data/Json/Token.hs b/src/HaskellWorks/Data/Json/Token.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Json/Token.hs +++ /dev/null @@ -1,6 +0,0 @@ -module HaskellWorks.Data.Json.Token - ( module X - ) where - -import HaskellWorks.Data.Json.Token.Types as X -import HaskellWorks.Data.Json.Token.Tokenize as X diff --git a/src/HaskellWorks/Data/Json/Token/Tokenize.hs b/src/HaskellWorks/Data/Json/Token/Tokenize.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Json/Token/Tokenize.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module HaskellWorks.Data.Json.Token.Tokenize - ( IsChar(..) - , JsonToken(..) - , ParseJson(..) - ) where - -import Control.Applicative -import Data.Bits -import Data.Char -import Data.Word -import Data.Word8 -import HaskellWorks.Data.Char.IsChar -import HaskellWorks.Data.Json.Token.Types -import HaskellWorks.Data.Parser as P - -import qualified Data.Attoparsec.ByteString.Char8 as BC -import qualified Data.Attoparsec.Combinator as AC -import qualified Data.Attoparsec.Types as T -import qualified Data.ByteString as BS - -hexDigitNumeric :: P.Parser t u => T.Parser t Int -hexDigitNumeric = do - c <- satisfyChar (\c -> '0' <= c && c <= '9') - return $ ord c - ord '0' - -hexDigitAlphaLower :: P.Parser t u => T.Parser t Int -hexDigitAlphaLower = do - c <- satisfyChar (\c -> 'a' <= c && c <= 'z') - return $ ord c - ord 'a' + 10 - -hexDigitAlphaUpper :: P.Parser t u => T.Parser t Int -hexDigitAlphaUpper = do - c <- satisfyChar (\c -> 'A' <= c && c <= 'Z') - return $ ord c - ord 'A' + 10 - -hexDigit :: P.Parser t u => T.Parser t Int -hexDigit = hexDigitNumeric <|> hexDigitAlphaLower <|> hexDigitAlphaUpper - -class ParseJson t s d where - parseJsonTokenString :: T.Parser t (JsonToken s d) - parseJsonToken :: T.Parser t (JsonToken s d) - parseJsonTokenBraceL :: T.Parser t (JsonToken s d) - parseJsonTokenBraceR :: T.Parser t (JsonToken s d) - parseJsonTokenBracketL :: T.Parser t (JsonToken s d) - parseJsonTokenBracketR :: T.Parser t (JsonToken s d) - parseJsonTokenComma :: T.Parser t (JsonToken s d) - parseJsonTokenColon :: T.Parser t (JsonToken s d) - parseJsonTokenWhitespace :: T.Parser t (JsonToken s d) - parseJsonTokenNull :: T.Parser t (JsonToken s d) - parseJsonTokenBoolean :: T.Parser t (JsonToken s d) - parseJsonTokenDouble :: T.Parser t (JsonToken s d) - - parseJsonToken = - parseJsonTokenString <|> - parseJsonTokenBraceL <|> - parseJsonTokenBraceR <|> - parseJsonTokenBracketL <|> - parseJsonTokenBracketR <|> - parseJsonTokenComma <|> - parseJsonTokenColon <|> - parseJsonTokenWhitespace <|> - parseJsonTokenNull <|> - parseJsonTokenBoolean <|> - parseJsonTokenDouble - -instance ParseJson BS.ByteString String Double where - parseJsonTokenBraceL = string "{" >> return JsonTokenBraceL - parseJsonTokenBraceR = string "}" >> return JsonTokenBraceR - parseJsonTokenBracketL = string "[" >> return JsonTokenBracketL - parseJsonTokenBracketR = string "]" >> return JsonTokenBracketR - parseJsonTokenComma = string "," >> return JsonTokenComma - parseJsonTokenColon = string ":" >> return JsonTokenColon - parseJsonTokenNull = string "null" >> return JsonTokenNull - parseJsonTokenDouble = JsonTokenNumber <$> rational - - parseJsonTokenString = do - _ <- string "\"" - value <- many (verbatimChar <|> escapedChar <|> escapedCode) - _ <- string "\"" - return $ JsonTokenString value - where - verbatimChar = satisfyChar (BC.notInClass "\"\\") "invalid string character" - escapedChar = do - _ <- string "\\" - ( char '"' >> return '"' ) <|> - ( char 'b' >> return '\b' ) <|> - ( char 'n' >> return '\n' ) <|> - ( char 'f' >> return '\f' ) <|> - ( char 'r' >> return '\r' ) <|> - ( char 't' >> return '\t' ) <|> - ( char '\\' >> return '\\' ) <|> - ( char '\'' >> return '\'' ) <|> - ( char '/' >> return '/' ) - escapedCode = do - _ <- string "\\u" - a <- hexDigit - b <- hexDigit - c <- hexDigit - d <- hexDigit - return $ chr $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d - - parseJsonTokenWhitespace = do - _ <- AC.many1' $ BC.choice [string " ", string "\t", string "\n", string "\r"] - return JsonTokenWhitespace - - parseJsonTokenBoolean = true <|> false - where - true = string "true" >> return (JsonTokenBoolean True) - false = string "false" >> return (JsonTokenBoolean False) - -instance ParseJson BS.ByteString BS.ByteString Double where - parseJsonTokenBraceL = string "{" >> return JsonTokenBraceL - parseJsonTokenBraceR = string "}" >> return JsonTokenBraceR - parseJsonTokenBracketL = string "[" >> return JsonTokenBracketL - parseJsonTokenBracketR = string "]" >> return JsonTokenBracketR - parseJsonTokenComma = string "," >> return JsonTokenComma - parseJsonTokenColon = string ":" >> return JsonTokenColon - parseJsonTokenNull = string "null" >> return JsonTokenNull - parseJsonTokenDouble = JsonTokenNumber <$> rational - - parseJsonTokenString = do - _ <- string "\"" - value <- many (verbatimChar <|> escapedChar <|> escapedCode) - _ <- string "\"" - return $ JsonTokenString $ BS.pack value - where - word :: Word8 -> T.Parser BS.ByteString Word8 - word w = satisfy (== w) - verbatimChar :: T.Parser BS.ByteString Word8 - verbatimChar = satisfy (\w -> w /= _quotedbl && w /= _backslash) -- "invalid string character" - escapedChar :: T.Parser BS.ByteString Word8 - escapedChar = do - _ <- string "\\" - ( word _quotedbl >> return _quotedbl ) <|> - ( word _b >> return 0x08 ) <|> - ( word _n >> return _lf ) <|> - ( word _f >> return _np ) <|> - ( word _r >> return _cr ) <|> - ( word _t >> return _tab ) <|> - ( word _backslash >> return _backslash ) <|> - ( word _quotesingle >> return _quotesingle ) <|> - ( word _slash >> return _slash ) - escapedCode :: T.Parser BS.ByteString Word8 - escapedCode = do - _ <- string "\\u" - a <- hexDigit - b <- hexDigit - c <- hexDigit - d <- hexDigit - return $ fromIntegral $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d - - parseJsonTokenWhitespace = do - _ <- AC.many1' $ BC.choice [string " ", string "\t", string "\n", string "\r"] - return JsonTokenWhitespace - - parseJsonTokenBoolean = true <|> false - where - true = string "true" >> return (JsonTokenBoolean True) - false = string "false" >> return (JsonTokenBoolean False) diff --git a/src/HaskellWorks/Data/Json/Token/Types.hs b/src/HaskellWorks/Data/Json/Token/Types.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Json/Token/Types.hs +++ /dev/null @@ -1,15 +0,0 @@ -module HaskellWorks.Data.Json.Token.Types (JsonToken(..)) where - -data JsonToken s d - = JsonTokenBraceL - | JsonTokenBraceR - | JsonTokenBracketL - | JsonTokenBracketR - | JsonTokenComma - | JsonTokenColon - | JsonTokenWhitespace - | JsonTokenString s - | JsonTokenBoolean Bool - | JsonTokenNumber d - | JsonTokenNull - deriving (Eq, Show) diff --git a/src/HaskellWorks/Data/Json/Type.hs b/src/HaskellWorks/Data/Json/Type.hs --- a/src/HaskellWorks/Data/Json/Type.hs +++ b/src/HaskellWorks/Data/Json/Type.hs @@ -12,6 +12,7 @@ import HaskellWorks.Data.Bits.BitWise import HaskellWorks.Data.Drop import HaskellWorks.Data.Json.Cursor +import HaskellWorks.Data.Json.Internal.Words import HaskellWorks.Data.Positioning import HaskellWorks.Data.RankSelect.Base.Rank0 import HaskellWorks.Data.RankSelect.Base.Rank1 @@ -22,9 +23,6 @@ import qualified HaskellWorks.Data.BalancedParens as BP {-# ANN module ("HLint: Reduce duplication" :: String) #-} - -wIsJsonNumberDigit :: Word8 -> Bool -wIsJsonNumberDigit w = (w >= _0 && w <= _9) || w == _hyphen data JsonType = JsonTypeArray diff --git a/src/HaskellWorks/Data/Json/Value.hs b/src/HaskellWorks/Data/Json/Value.hs --- a/src/HaskellWorks/Data/Json/Value.hs +++ b/src/HaskellWorks/Data/Json/Value.hs @@ -7,8 +7,8 @@ module HaskellWorks.Data.Json.Value where import HaskellWorks.Data.Json.DecodeError -import HaskellWorks.Data.Json.Succinct.Index -import HaskellWorks.Data.Json.Value.Internal +import HaskellWorks.Data.Json.Internal.Index +import HaskellWorks.Data.Json.Internal.Value import qualified Data.Attoparsec.ByteString.Char8 as ABC import qualified Data.ByteString as BS diff --git a/src/HaskellWorks/Data/Json/Value/Internal.hs b/src/HaskellWorks/Data/Json/Value/Internal.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Json/Value/Internal.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - -module HaskellWorks.Data.Json.Value.Internal where - -import Control.Applicative -import Data.Bits -import Data.Char -import Data.String -import HaskellWorks.Data.Parser as P - -import qualified Data.Attoparsec.ByteString.Char8 as ABC -import qualified Data.Attoparsec.Types as T - -parseHexDigitNumeric :: P.Parser t u => T.Parser t Int -parseHexDigitNumeric = do - c <- satisfyChar (\c -> '0' <= c && c <= '9') - return $ ord c - ord '0' - -parseHexDigitAlphaLower :: P.Parser t u => T.Parser t Int -parseHexDigitAlphaLower = do - c <- satisfyChar (\c -> 'a' <= c && c <= 'z') - return $ ord c - ord 'a' + 10 - -parseHexDigitAlphaUpper :: P.Parser t u => T.Parser t Int -parseHexDigitAlphaUpper = do - c <- satisfyChar (\c -> 'A' <= c && c <= 'Z') - return $ ord c - ord 'A' + 10 - -parseHexDigit :: P.Parser t u => T.Parser t Int -parseHexDigit = parseHexDigitNumeric <|> parseHexDigitAlphaLower <|> parseHexDigitAlphaUpper - -parseJsonString :: (P.Parser t u, IsString t) => T.Parser t String -parseJsonString = do - _ <- string "\"" - value <- many (verbatimChar <|> escapedChar <|> escapedCode) - _ <- string "\"" - return value - where - verbatimChar = satisfyChar (ABC.notInClass "\"\\") "invalid string character" - escapedChar = do - _ <- string "\\" - ( char '"' >> return '"' ) <|> - ( char 'b' >> return '\b' ) <|> - ( char 'n' >> return '\n' ) <|> - ( char 'f' >> return '\f' ) <|> - ( char 'r' >> return '\r' ) <|> - ( char 't' >> return '\t' ) <|> - ( char '\\' >> return '\\' ) <|> - ( char '\'' >> return '\'' ) <|> - ( char '/' >> return '/' ) - escapedCode = do - _ <- string "\\u" - a <- parseHexDigit - b <- parseHexDigit - c <- parseHexDigit - d <- parseHexDigit - return $ chr $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d diff --git a/test/HaskellWorks/Data/Json/CorpusSpec.hs b/test/HaskellWorks/Data/Json/CorpusSpec.hs --- a/test/HaskellWorks/Data/Json/CorpusSpec.hs +++ b/test/HaskellWorks/Data/Json/CorpusSpec.hs @@ -14,7 +14,6 @@ import Data.Word import HaskellWorks.Data.BalancedParens.Simple -import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.Bits.FromBitTextByteString import HaskellWorks.Data.FromByteString import HaskellWorks.Data.Json.Cursor @@ -35,12 +34,12 @@ inInterestBalancedParensBS <- BS.readFile "corpus/5000B.bp" let inInterestBits = fromBitTextByteString inInterestBitsBS let inInterestBalancedParens = fromBitTextByteString inInterestBalancedParensBS - let !cursor = fromByteString inJsonBS :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + let !cursor = fromByteString inJsonBS :: JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64)) let text = cursorText cursor let ib = interests cursor let SimpleBalancedParens bp = balancedParens cursor text `shouldBe` inJsonBS - ib `shouldBe` BitShown inInterestBits + ib `shouldBe` inInterestBits bp `shouldBe` inInterestBalancedParens it "issue-0001 loads properly" $ do inJsonBS <- BS.readFile "corpus/issue-0001.json" @@ -48,10 +47,10 @@ inInterestBalancedParensBS <- BS.readFile "corpus/issue-0001.bp" let inInterestBits = fromBitTextByteString inInterestBitsBS let inInterestBalancedParens = fromBitTextByteString inInterestBalancedParensBS - let !cursor = fromByteString inJsonBS :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + let !cursor = fromByteString inJsonBS :: JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64)) let text = cursorText cursor let ib = interests cursor let SimpleBalancedParens bp = balancedParens cursor text `shouldBe` inJsonBS - ib `shouldBe` BitShown inInterestBits + ib `shouldBe` inInterestBits bp `shouldBe` inInterestBalancedParens diff --git a/test/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParensSpec.hs b/test/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParensSpec.hs --- a/test/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParensSpec.hs +++ b/test/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParensSpec.hs @@ -6,20 +6,20 @@ import Data.String import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.Json.Internal.MakeIndex -import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson import Test.Hspec -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS +import qualified HaskellWorks.Data.Json.Internal.BlankedJson as J {-# ANN module ("HLint: Ignore Redundant do" :: String) #-} spec :: Spec spec = describe "HaskellWorks.Data.Json.Succinct.Cursor.BalancedParensSpec" $ do it "Blanking JSON should not contain strange characters 1" $ do - let blankedJson = BlankedJson ["[ [],", "[]]"] - let bp = BitShown $ BS.concat (blankedJsonToBalancedParens2 (getBlankedJson blankedJson)) + let blankedJson = J.BlankedJson ["[ [],", "[]]"] + let bp = BitShown $ BS.concat (blankedJsonToBalancedParens (J.unBlankedJson blankedJson)) bp `shouldBe` fromString "11111111 11111111 00000000 11111111 00000000 00000000" it "Blanking JSON should not contain strange characters 2" $ do - let blankedJson = BlankedJson ["[ [],", "[]]"] - let bp = BitShown $ BS.concat ((compressWordAsBit . blankedJsonToBalancedParens2) (getBlankedJson blankedJson)) + let blankedJson = J.BlankedJson ["[ [],", "[]]"] + let bp = BitShown $ BS.concat ((compressWordAsBit . blankedJsonToBalancedParens) (J.unBlankedJson blankedJson)) bp `shouldBe` fromString "11010000" diff --git a/test/HaskellWorks/Data/Json/Succinct/Cursor/InterestBitsSpec.hs b/test/HaskellWorks/Data/Json/Succinct/Cursor/InterestBitsSpec.hs --- a/test/HaskellWorks/Data/Json/Succinct/Cursor/InterestBitsSpec.hs +++ b/test/HaskellWorks/Data/Json/Succinct/Cursor/InterestBitsSpec.hs @@ -7,34 +7,33 @@ import Data.String import Data.Word import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.FromByteString -import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson -import HaskellWorks.Data.Json.Succinct.Cursor.InterestBits import Test.Hspec -import qualified Data.ByteString as BS -import qualified Data.Vector.Storable as DVS +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS +import qualified HaskellWorks.Data.Json.Internal.BlankedJson as J +import qualified HaskellWorks.Data.Json.Internal.ToInterestBits64 as J {-# ANN module ("HLint: ignore Redundant do" :: String) #-} -interestBitsOf :: FromBlankedJson (JsonInterestBits a) => BS.ByteString -> a -interestBitsOf = getJsonInterestBits . fromBlankedJson . fromByteString +interestBitsOf :: BS.ByteString -> DVS.Vector Word64 +interestBitsOf bs = J.toInterestBits64 (J.toBlankedJsonTyped bs) spec :: Spec spec = describe "HaskellWorks.Data.Json.Succinct.Cursor.InterestBitsSpec" $ do it "Evaluating interest bits" $ do - (interestBitsOf "" :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "" - (interestBitsOf " \n \r \t " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" - (interestBitsOf "1234 " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" - (interestBitsOf "false " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" - (interestBitsOf "true " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" - (interestBitsOf "\"hello\" " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" - (interestBitsOf "\"\\\"\" " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" - (interestBitsOf "{ " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" - (interestBitsOf "} " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" - (interestBitsOf "[ " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" - (interestBitsOf "] " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" - (interestBitsOf ": " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" - (interestBitsOf ", " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" - (interestBitsOf "{{}}" :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "11000000" - (interestBitsOf " { { } } " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "01010000 00000000" + BitShown (interestBitsOf "" ) `shouldBe` fromString "" + BitShown (interestBitsOf " \n \r \t ") `shouldBe` fromString "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf "1234 " ) `shouldBe` fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf "false " ) `shouldBe` fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf "true " ) `shouldBe` fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf "\"hello\" " ) `shouldBe` fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf "\"\\\"\" " ) `shouldBe` fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf "{ " ) `shouldBe` fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf "} " ) `shouldBe` fromString "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf "[ " ) `shouldBe` fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf "] " ) `shouldBe` fromString "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf ": " ) `shouldBe` fromString "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf ", " ) `shouldBe` fromString "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf "{{}}" ) `shouldBe` fromString "11000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" + BitShown (interestBitsOf " { { } } " ) `shouldBe` fromString "01010000 00000000 00000000 00000000 00000000 00000000 00000000 00000000" diff --git a/test/HaskellWorks/Data/Json/Succinct/CursorSpec.hs b/test/HaskellWorks/Data/Json/Succinct/CursorSpec.hs --- a/test/HaskellWorks/Data/Json/Succinct/CursorSpec.hs +++ b/test/HaskellWorks/Data/Json/Succinct/CursorSpec.hs @@ -16,14 +16,12 @@ import Data.Word import HaskellWorks.Data.BalancedParens.BalancedParens import HaskellWorks.Data.BalancedParens.Simple -import HaskellWorks.Data.Bits.BitShow -import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.Bits.BitWise import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.Json.Cursor -import HaskellWorks.Data.Json.Succinct.Cursor.Token -import HaskellWorks.Data.Json.Succinct.Index -import HaskellWorks.Data.Json.Token +import HaskellWorks.Data.Json.Internal.Cursor.Token +import HaskellWorks.Data.Json.Internal.Index +import HaskellWorks.Data.Json.Internal.Token import HaskellWorks.Data.RankSelect.Base.Rank0 import HaskellWorks.Data.RankSelect.Base.Rank1 import HaskellWorks.Data.RankSelect.Base.Select1 @@ -41,51 +39,13 @@ fc = TC.firstChild ns = TC.nextSibling pn = TC.parent --- cd = TC.depth ss = TC.subtreeSize spec :: Spec spec = describe "HaskellWorks.Data.Json.Succinct.CursorSpec" $ do - -- describe "Cursor for [Bool]" $ do - -- it "depth at top" $ do - -- let cursor = "[null]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - -- cd cursor `shouldBe` Just 1 - -- it "depth at first child of array" $ do - -- let cursor = "[null]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - -- (fc >=> cd) cursor `shouldBe` Just 2 - -- it "depth at second child of array" $ do - -- let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - -- (fc >=> ns >=> cd) cursor `shouldBe` Just 2 - -- it "depth at first child of object at second child of array" $ do - -- let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - -- (fc >=> ns >=> fc >=> cd) cursor `shouldBe` Just 3 - -- it "depth at first child of object at second child of array" $ do - -- let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - -- (fc >=> ns >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3 - genSpec "DVS.Vector Word8" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) - genSpec "DVS.Vector Word16" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) - genSpec "DVS.Vector Word32" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) - genSpec "DVS.Vector Word64" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + genSpec "DVS.Vector Word64" (undefined :: JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64))) genSpec "Poppy512" (undefined :: JsonCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) - it "Loads same Json consistentally from different backing vectors" $ do - let cursor8 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8)) - let cursor16 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16)) - let cursor32 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32)) - let cursor64 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) - cursorText cursor8 `shouldBe` cursorText cursor16 - cursorText cursor8 `shouldBe` cursorText cursor32 - cursorText cursor8 `shouldBe` cursorText cursor64 - let ic8 = bitShow $ interests cursor8 - let ic16 = bitShow $ interests cursor16 - let ic32 = bitShow $ interests cursor32 - let ic64 = bitShow $ interests cursor64 - ic16 `shouldBeginWith` ic8 - ic32 `shouldBeginWith` ic16 - ic64 `shouldBeginWith` ic32 -shouldBeginWith :: (Eq a, Show a) => [a] -> [a] -> IO () -shouldBeginWith as bs = take (length bs) as `shouldBe` bs - genSpec :: forall t u. ( Eq t , Show t @@ -101,17 +61,6 @@ => String -> (JsonCursor BS.ByteString t u) -> SpecWith () genSpec t _ = do describe ("Json cursor of type " ++ t) $ do - -- let forJson (cursor :: JsonCursor BS.ByteString t u) f = describe ("of value " ++ show cursor) (f cursor) - -- forJson "[null]" $ \cursor -> do - -- it "depth at top" $ cd cursor `shouldBe` Just 1 - -- it "depth at first child of array" $ (fc >=> cd) cursor `shouldBe` Just 2 - -- forJson "[null, {\"field\": 1}]" $ \cursor -> do - -- it "depth at second child of array" $ do - -- (fc >=> ns >=> cd) cursor `shouldBe` Just 2 - -- it "depth at first child of object at second child of array" $ do - -- (fc >=> ns >=> fc >=> cd) cursor `shouldBe` Just 3 - -- it "depth at first child of object at second child of array" $ do - -- (fc >=> ns >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3 describe "For empty json array" $ do let cursor = "[null]" :: JsonCursor BS.ByteString t u it "can navigate down and forwards" $ do diff --git a/test/HaskellWorks/Data/Json/Token/TokenizeSpec.hs b/test/HaskellWorks/Data/Json/Token/TokenizeSpec.hs --- a/test/HaskellWorks/Data/Json/Token/TokenizeSpec.hs +++ b/test/HaskellWorks/Data/Json/Token/TokenizeSpec.hs @@ -2,8 +2,8 @@ module HaskellWorks.Data.Json.Token.TokenizeSpec (spec) where -import Data.ByteString as BS -import HaskellWorks.Data.Json.Token.Tokenize +import Data.ByteString (ByteString) +import HaskellWorks.Data.Json.Internal.Token.Tokenize import Test.Hspec import qualified Data.Attoparsec.ByteString.Char8 as BC diff --git a/test/HaskellWorks/Data/Json/TypeSpec.hs b/test/HaskellWorks/Data/Json/TypeSpec.hs --- a/test/HaskellWorks/Data/Json/TypeSpec.hs +++ b/test/HaskellWorks/Data/Json/TypeSpec.hs @@ -16,7 +16,6 @@ import Data.Word import HaskellWorks.Data.BalancedParens.BalancedParens import HaskellWorks.Data.BalancedParens.Simple -import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.Bits.BitWise import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.Json.Cursor @@ -40,47 +39,7 @@ spec :: Spec spec = describe "HaskellWorks.Data.Json.Succinct.CursorSpec" $ do - describe "Cursor for [Bool]" $ do - it "initialises to beginning of empty object" $ do - let cursor = "{}" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - jsonTypeAt cursor `shouldBe` Just JsonTypeObject - it "initialises to beginning of empty object preceded by spaces" $ do - let cursor = " {}" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - jsonTypeAt cursor `shouldBe` Just JsonTypeObject - it "initialises to beginning of number" $ do - let cursor = "1234" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - jsonTypeAt cursor `shouldBe` Just JsonTypeNumber - it "initialises to beginning of string" $ do - let cursor = "\"Hello\"" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - jsonTypeAt cursor `shouldBe` Just JsonTypeString - it "initialises to beginning of array" $ do - let cursor = "[]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - jsonTypeAt cursor `shouldBe` Just JsonTypeArray - it "initialises to beginning of boolean true" $ do - let cursor = "true" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - jsonTypeAt cursor `shouldBe` Just JsonTypeBool - it "initialises to beginning of boolean false" $ do - let cursor = "false" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - jsonTypeAt cursor `shouldBe` Just JsonTypeBool - it "initialises to beginning of null" $ do - let cursor = "null" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - jsonTypeAt cursor `shouldBe` Just JsonTypeNull - it "cursor can navigate to first child of array" $ do - let cursor = "[null]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - (fc >=> jsonTypeAt) cursor `shouldBe` Just JsonTypeNull - it "cursor can navigate to second child of array" $ do - let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - (fc >=> ns >=> jsonTypeAt) cursor `shouldBe` Just JsonTypeObject - it "cursor can navigate to first child of object at second child of array" $ do - let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - (fc >=> ns >=> fc >=> jsonTypeAt) cursor `shouldBe` Just JsonTypeString - it "cursor can navigate to first child of object at second child of array" $ do - let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - (fc >=> ns >=> fc >=> ns >=> jsonTypeAt) cursor `shouldBe` Just JsonTypeNumber - genSpec "DVS.Vector Word8" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) - genSpec "DVS.Vector Word16" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) - genSpec "DVS.Vector Word32" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) - genSpec "DVS.Vector Word64" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + genSpec "DVS.Vector Word64" (undefined :: JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64))) genSpec "Poppy512" (undefined :: JsonCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) genSpec :: forall t u. diff --git a/test/HaskellWorks/Data/Json/ValueSpec.hs b/test/HaskellWorks/Data/Json/ValueSpec.hs --- a/test/HaskellWorks/Data/Json/ValueSpec.hs +++ b/test/HaskellWorks/Data/Json/ValueSpec.hs @@ -16,12 +16,11 @@ import Data.Word import HaskellWorks.Data.BalancedParens.BalancedParens import HaskellWorks.Data.BalancedParens.Simple -import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.Bits.BitWise import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.Json.Cursor import HaskellWorks.Data.Json.DecodeError -import HaskellWorks.Data.Json.Succinct.Index +import HaskellWorks.Data.Json.Internal.Index import HaskellWorks.Data.Json.Value import HaskellWorks.Data.RankSelect.Base.Rank0 import HaskellWorks.Data.RankSelect.Base.Rank1 @@ -39,14 +38,10 @@ fc = TC.firstChild ns = TC.nextSibling --- cd = TC.depth spec :: Spec spec = describe "HaskellWorks.Data.Json.ValueSpec" $ do - genSpec "DVS.Vector Word8" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) - genSpec "DVS.Vector Word16" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) - genSpec "DVS.Vector Word32" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) - genSpec "DVS.Vector Word64" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + genSpec "DVS.Vector Word64" (undefined :: JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64))) genSpec "Poppy512" (undefined :: JsonCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) jsonValueVia :: @@ -95,18 +90,10 @@ forJson "[null]" $ \cursor -> do it "should have correct value" $ jsonValueVia (Just cursor) `shouldBe` Right (JsonArray [JsonNull]) it "should have correct value" $ jsonValueVia (fc cursor) `shouldBe` Right JsonNull - -- it "depth at top" $ cd cursor `shouldBe` Just 1 - -- it "depth at first child of array" $ (fc >=> cd) cursor `shouldBe` Just 2 forJson "[null, {\"field\": 1}]" $ \cursor -> do it "cursor can navigate to second child of array" $ do jsonValueVia ((fc >=> ns) cursor) `shouldBe` Right ( JsonObject [("field", JsonNumber 1)] ) jsonValueVia (Just cursor) `shouldBe` Right (JsonArray [JsonNull, JsonObject [("field", JsonNumber 1)]]) - -- it "depth at second child of array" $ do - -- (fc >=> ns >=> cd) cursor `shouldBe` Just 2 - -- it "depth at first child of object at second child of array" $ do - -- (fc >=> ns >=> fc >=> cd) cursor `shouldBe` Just 3 - -- it "depth at first child of object at second child of array" $ do - -- (fc >=> ns >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3 describe "For empty json array" $ do let cursor = "[]" :: JsonCursor BS.ByteString t u it "can navigate down and forwards" $ do