hw-json 1.0.0.2 → 1.3.3.1
raw patch · 73 files changed
Files
- README.md +34/−48
- app/App/Commands.hs +6/−1
- app/App/Commands/Count.hs +99/−0
- app/App/Commands/CountAeson.hs +53/−0
- app/App/Commands/CreateIndex.hs +29/−19
- app/App/Commands/Demo.hs +15/−34
- app/App/Commands/Types.hs +21/−1
- app/Main.hs +0/−1
- bench/Main.hs +1/−65
- doctest/DoctestDriver.hs +12/−0
- examples/Example1.hs +17/−0
- examples/Example2.hs +17/−0
- examples/Example3.hs +24/−0
- examples/Example4.hs +55/−0
- hw-json.cabal +224/−198
- src/HaskellWorks/Data/Json.hs +0/−11
- src/HaskellWorks/Data/Json/Backend/Simple/Cursor.hs +0/−89
- src/HaskellWorks/Data/Json/Backend/Simple/Fast.hs +0/−38
- src/HaskellWorks/Data/Json/Backend/Simple/SemiIndex.hs +0/−80
- src/HaskellWorks/Data/Json/Backend/Simple/Value.hs +0/−43
- src/HaskellWorks/Data/Json/Backend/Standard/Cursor.hs +0/−173
- src/HaskellWorks/Data/Json/Backend/Standard/Fast.hs +0/−38
- src/HaskellWorks/Data/Json/Backend/Standard/Index.hs +0/−20
- src/HaskellWorks/Data/Json/Backend/Standard/Load/Cursor.hs +0/−53
- src/HaskellWorks/Data/Json/Backend/Standard/Load/Partial.hs +0/−54
- src/HaskellWorks/Data/Json/Backend/Standard/Load/Raw.hs +0/−20
- src/HaskellWorks/Data/Json/Backend/Standard/SemiIndex.hs +0/−269
- src/HaskellWorks/Data/Json/Backend/Standard/Slow.hs +0/−36
- src/HaskellWorks/Data/Json/FromValue.hs +19/−12
- src/HaskellWorks/Data/Json/Internal/Backend/Simple/IbBp.hs +0/−10
- src/HaskellWorks/Data/Json/Internal/Backend/Simple/ToIbBp.hs +0/−12
- src/HaskellWorks/Data/Json/Internal/Backend/Standard/Blank.hs +0/−56
- src/HaskellWorks/Data/Json/Internal/Backend/Standard/BlankedJson.hs +0/−24
- src/HaskellWorks/Data/Json/Internal/Backend/Standard/Cursor/Token.hs +0/−24
- src/HaskellWorks/Data/Json/Internal/Backend/Standard/IbBp.hs +0/−24
- src/HaskellWorks/Data/Json/Internal/Backend/Standard/MakeIndex.hs +0/−134
- src/HaskellWorks/Data/Json/Internal/Backend/Standard/StateMachine.hs +0/−109
- src/HaskellWorks/Data/Json/Internal/Backend/Standard/ToBalancedParens64.hs +0/−28
- src/HaskellWorks/Data/Json/Internal/Backend/Standard/ToInterestBits64.hs +0/−31
- src/HaskellWorks/Data/Json/Internal/Backend/Standard/Token/Tokenize.hs +0/−165
- src/HaskellWorks/Data/Json/Internal/CharLike.hs +1/−1
- src/HaskellWorks/Data/Json/Internal/Doc.hs +19/−3
- src/HaskellWorks/Data/Json/Internal/Index.hs +40/−2
- src/HaskellWorks/Data/Json/Internal/PartialIndex.hs +52/−1
- src/HaskellWorks/Data/Json/Internal/Slurp.hs +34/−23
- src/HaskellWorks/Data/Json/Internal/Standard/Cursor/Token.hs +24/−0
- src/HaskellWorks/Data/Json/Internal/Standard/Token/Tokenize.hs +166/−0
- src/HaskellWorks/Data/Json/Internal/Token.hs +1/−1
- src/HaskellWorks/Data/Json/Internal/Value.hs +4/−2
- src/HaskellWorks/Data/Json/Internal/Word64.hs +1/−1
- src/HaskellWorks/Data/Json/Internal/Word8.hs +0/−72
- src/HaskellWorks/Data/Json/LightJson.hs +81/−13
- src/HaskellWorks/Data/Json/PartialValue.hs +70/−28
- src/HaskellWorks/Data/Json/Query.hs +8/−8
- src/HaskellWorks/Data/Json/Simple/Value.hs +42/−0
- src/HaskellWorks/Data/Json/Standard/Load/Partial.hs +34/−0
- src/HaskellWorks/Data/Json/Type.hs +0/−26
- src/HaskellWorks/Data/Json/Value.hs +30/−6
- test/HaskellWorks/Data/Json/Backend/Simple/CursorSpec.hs +0/−85
- test/HaskellWorks/Data/Json/Backend/Standard/Succinct/Cursor/BalancedParensSpec.hs +0/−43
- test/HaskellWorks/Data/Json/Backend/Standard/Succinct/Cursor/InterestBitsSpec.hs +0/−67
- test/HaskellWorks/Data/Json/Backend/Standard/Succinct/CursorSpec.hs +0/−33
- test/HaskellWorks/Data/Json/Backend/Standard/Succinct/GenCursorTest.hs +0/−103
- test/HaskellWorks/Data/Json/CorpusSpec.hs +0/−57
- test/HaskellWorks/Data/Json/Internal/BlankSpec.hs +0/−51
- test/HaskellWorks/Data/Json/LightJsonSpec.hs +148/−0
- test/HaskellWorks/Data/Json/Simple/CursorSpec.hs +85/−0
- test/HaskellWorks/Data/Json/Standard/CursorSpec.hs +25/−0
- test/HaskellWorks/Data/Json/Standard/GenCursorTest.hs +101/−0
- test/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParensSpec.hs +0/−27
- test/HaskellWorks/Data/Json/Token/TokenizeSpec.hs +3/−3
- test/HaskellWorks/Data/Json/TypeSpec.hs +14/−20
- test/HaskellWorks/Data/Json/ValueSpec.hs +17/−20
README.md view
@@ -1,4 +1,5 @@ # hw-json+ [](https://circleci.com/gh/haskell-works/hw-json/tree/master) `hw-json` is a succinct JSON parsing library.@@ -10,9 +11,19 @@ ## Prerequisites * `cabal` version `2.2` or later+* Depending on your use case you may need additional package dependencies. These can be found in the library dependencies of the examples+ library component in the cabal file. ## Memory benchmark +If you need a repl to run any of the Haskell examples in this README, please run the command:++```bash+cabal v2-repl lib:examples+```++For rexamples these examples are also found in Haskell modules under the `examples` directory.+ ### Parsing large Json files in Scala with Argonaut ```text@@ -34,12 +45,11 @@ ```haskell -- CMD -- Mem (MB) ---------------------------------------------------------- -- ---------import Control.DeepSeq -- 94-import Data.Aeson -- 100-import qualified Data.ByteString.Lazy as BSL -- 104-bs <- BSL.readFile "../corpus/bench/hospitalisation.json" -- 105-let !x = deepseq bs bs -- 146-let !y = decode json78m :: Maybe Value -- 669+import Control.DeepSeq -- 345+import Data.Aeson -- 371+import qualified Data.ByteString.Lazy as LBS -- 376+!bs <- LBS.readFile "corpus/bench/hospitalisation.json" -- 380+let !y = decode bs :: Maybe Value -- 928 ``` ### Parsing large Json files in Haskell with hw-json@@ -47,20 +57,12 @@ ```haskell -- CMD -- Mem (MB) --------------------------------------------------------------------- -- ---------import Foreign -- 93-import Control.Monad -- 95-import Data.Word -- 96-import HaskellWorks.Data.BalancedParens.Simple -- 97-import HaskellWorks.Data.Bits.BitShown -- 98-import HaskellWorks.Data.FromForeignRegion -- 99-import HaskellWorks.Data.Json.Backend.Standard.Cursor -- 106-import System.IO.MMap -- 109-import qualified Data.ByteString as BS -- 110-import qualified Data.Vector.Storable as DVS -- 111-import qualified HaskellWorks.Data.ByteString as BS -- 112-import qualified HaskellWorks.Data.Json.Backend.Standard.Fast as FAST -- 114-bs <- BS.mmap "../corpus/bench/hospitalisation.json" -- 115-let !cursor = FAST.makeCursor bs -- 203+import qualified HaskellWorks.Data.ByteString as BS -- 351+import qualified HaskellWorks.Data.Json.Standard.Cursor.Fast as JCF -- 353++!jsonBs <- BS.mmap "corpus/bench/hospitalisation.json" -- 355+let !ibip = JCF.simdToIbBp jsonBs -- 358+let !c = JCF.fromBsIbBp jsonBs ibip -- 495 ``` ## Examples@@ -69,32 +71,18 @@ ```haskell import Control.Monad-import Data.String-import Data.Word-import HaskellWorks.Data.BalancedParens.Simple-import HaskellWorks.Data.Bits.BitShow-import HaskellWorks.Data.Bits.BitShown-import HaskellWorks.Data.FromForeignRegion-import HaskellWorks.Data.Json.Backend.Standard.Cursor-import HaskellWorks.Data.Json.Internal.Token.Types-import HaskellWorks.Data.RankSelect.Base.Rank0-import HaskellWorks.Data.RankSelect.Base.Rank1-import HaskellWorks.Data.RankSelect.Base.Select1-import HaskellWorks.Data.RankSelect.Poppy512-import System.IO.MMap -import qualified Data.ByteString as BS-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.Json.Backend.Standard.Cursor as C-import qualified HaskellWorks.Data.Json.Backend.Standard.Fast as FAST-import qualified HaskellWorks.Data.TreeCursor as TC+import qualified Data.ByteString as BS+import qualified HaskellWorks.Data.Json.Standard.Cursor.Fast as JCF+import qualified HaskellWorks.Data.TreeCursor as TC let fc = TC.firstChild let ns = TC.nextSibling let pn = TC.parent let ss = TC.subtreeSize-let cursor = FAST.makeCursor "[null, {\"field\": 1}]"-cursor+let jsonBs = "[null, {\"field\": 1}]" :: BS.ByteString+let ibip = JCF.simdToIbBp jsonBs+let cursor = JCF.fromBsIbBp jsonBs ibip fc cursor (fc >=> ns) cursor ```@@ -105,20 +93,18 @@ import Control.Monad import Data.Function import Data.List-import HaskellWorks.Data.Json.Backend.Standard.Load.Cursor-import HaskellWorks.Data.Json.Backend.Standard.Load.Partial-import HaskellWorks.Data.Json.Backend.Standard.Load.Raw import HaskellWorks.Data.Json.PartialValue+import HaskellWorks.Data.Json.Standard.Cursor.Load.Cursor+import HaskellWorks.Data.Json.Standard.Load.Partial import HaskellWorks.Data.MQuery import HaskellWorks.Data.MQuery.Micro-import HaskellWorks.Data.MQuery.Row import qualified Data.DList as DL -!cursor <- loadPartial "../corpus/bench/78mb.json"-!cursor <- loadCursorWithIndex "../corpus/bench/78mb.json"-!cursor <- loadCursor "../corpus/bench/78mb.json"-!cursor <- loadCursorWithCsPoppyIndex "../corpus/bench/78mb.json"+!cursor <- loadPartial "corpus/bench/78mb.json"+!cursor <- loadCursorWithIndex "corpus/bench/78mb.json"+!cursor <- loadCursor "corpus/bench/78mb.json"+!cursor <- loadCursorWithCsPoppyIndex "corpus/bench/78mb.json" let !json = jsonPartialJsonValueAt cursor let q = MQuery (DL.singleton json)
app/App/Commands.hs view
@@ -1,10 +1,13 @@ module App.Commands where +import App.Commands.Count+import App.Commands.CountAeson import App.Commands.CreateIndex import App.Commands.Demo-import Data.Semigroup ((<>)) import Options.Applicative +{- HLINT ignore "Monoid law, left identity" -}+ commands :: Parser (IO ()) commands = commandsGeneral @@ -12,4 +15,6 @@ commandsGeneral = subparser $ mempty <> commandGroup "Commands:" <> cmdCreateIndex+ <> cmdCount+ <> cmdCountAeson <> cmdDemo
+ app/App/Commands/Count.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module App.Commands.Count+ ( cmdCount+ ) where++import Control.Lens+import Control.Monad+import Data.Generics.Product.Any+import Data.Word+import HaskellWorks.Data.FromForeignRegion+import HaskellWorks.Data.Json.LightJson+import HaskellWorks.Data.Json.Query+import HaskellWorks.Data.Json.Standard.Cursor.Generic+import HaskellWorks.Data.MQuery+import HaskellWorks.Data.MQuery.Micro+import HaskellWorks.Data.RankSelect.CsPoppy1+import HaskellWorks.Data.TreeCursor+import Options.Applicative hiding (columns)++import qualified App.Commands.Types as Z+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BSI+import qualified Data.DList as DL+import qualified Data.Vector.Storable as DVS+import qualified HaskellWorks.Data.BalancedParens.RangeMin as RM+import qualified HaskellWorks.Data.Json.Standard.Cursor.Fast as JCF+import qualified System.IO.MMap as IO++siblings :: GenericCursor BSI.ByteString CsPoppy1 (RM.RangeMin CsPoppy1) -> [GenericCursor BSI.ByteString CsPoppy1 (RM.RangeMin CsPoppy1)]+siblings c = c:maybe [] siblings (nextSibling c)++runCount :: Z.CountOptions -> IO ()+#if aarch64_HOST_ARCH+runCount = undefined+#else+runCount opts = do+ let inputFile = opts ^. the @"inputFile"+ let expression = opts ^. the @"expression"+ jsonFr <- IO.mmapFileForeignPtr inputFile IO.ReadOnly Nothing+ let jsonBs = fromForeignRegion jsonFr :: BS.ByteString++ cursor <- case opts ^. the @"indexes" of+ Just indexes -> do+ let ibIndex = indexes ^. the @"ibIndex"+ let bpIndex = indexes ^. the @"bpIndex"+ jsonIbFr <- IO.mmapFileForeignPtr ibIndex IO.ReadOnly Nothing+ jsonBpFr <- IO.mmapFileForeignPtr bpIndex IO.ReadOnly Nothing+ let jsonIb = fromForeignRegion jsonIbFr :: DVS.Vector Word64+ let jsonBp = fromForeignRegion jsonBpFr :: DVS.Vector Word64++ return $ GenericCursor jsonBs (makeCsPoppy jsonIb) (RM.mkRangeMin (makeCsPoppy jsonBp)) 1+ Nothing -> do+ let !ibip = JCF.simdToIbBp jsonBs+ let !c = JCF.fromBsIbBp jsonBs ibip+ return c++ let q = MQuery (DL.fromList $ fmap lightJsonAt (siblings cursor))++ putPretty $ q >>= (entry >=> named expression) & count++ return ()+#endif++optsFileIndex :: Parser Z.FileIndexes+optsFileIndex = Z.FileIndexes+ <$> strOption+ ( long "ib-index"+ <> help "IB index"+ <> metavar "FILE"+ )+ <*> strOption+ ( long "bp-index"+ <> help "BP index"+ <> metavar "FILE"+ )++optsCount :: Parser Z.CountOptions+optsCount = Z.CountOptions+ <$> strOption+ ( long "input"+ <> short 'i'+ <> help "Input JSON file"+ <> metavar "FILE"+ )+ <*> optional optsFileIndex+ <*> strOption+ ( long "expression"+ <> help "JSON expression"+ <> metavar "EXPRESSION"+ )++cmdCount :: Mod CommandFields (IO ())+cmdCount = command "count" $ flip info idm $ runCount <$> optsCount
+ app/App/Commands/CountAeson.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module App.Commands.CountAeson+ ( cmdCountAeson+ ) where++import Control.Lens+import Data.Generics.Product.Any+import Options.Applicative hiding (columns)++import qualified App.Commands.Types as Z+import qualified Data.Aeson as J+import qualified Data.Aeson.Key as J+import qualified Data.Aeson.KeyMap as J+import qualified Data.ByteString.Lazy as LBS+import qualified System.IO as IO++runCountAeson :: Z.CountAesonOptions -> IO ()+runCountAeson opts = do+ let inputFile = opts ^. the @"inputFile"+ let expression = opts ^. the @"expression"++ lbs <- LBS.readFile inputFile++ let lbsLines = LBS.split 10 lbs++ let count :: Int = sum $ flip fmap lbsLines $ \lbsLine -> case J.decode lbsLine of+ Just (J.Object v) -> if J.member (J.fromText expression) v then 1 else 0+ _ -> 0++ IO.putStrLn $ "Count: " <> show count++ return ()++optsCountAeson :: Parser Z.CountAesonOptions+optsCountAeson = Z.CountAesonOptions+ <$> strOption+ ( long "input"+ <> short 'i'+ <> help "Input JSON file"+ <> metavar "FILE"+ )+ <*> strOption+ ( long "expression"+ <> help "JSON expression"+ <> metavar "EXPRESSION"+ )++cmdCountAeson :: Mod CommandFields (IO ())+cmdCountAeson = command "count-aeson" $ flip info idm $ runCountAeson <$> optsCountAeson
app/App/Commands/CreateIndex.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -11,32 +12,34 @@ import Control.Monad import Data.Generics.Product.Any import Data.Maybe-import Data.Semigroup ((<>)) import Data.Word import Foreign import Options.Applicative hiding (columns) -import qualified App.Commands.Types as Z-import qualified Data.ByteString as BS-import qualified Data.ByteString.Internal as BSI-import qualified Data.ByteString.Lazy as LBS-import qualified HaskellWorks.Data.ByteString as BS-import qualified HaskellWorks.Data.ByteString.Lazy as LBS-import qualified HaskellWorks.Data.Json.Backend.Simple.SemiIndex as SISI-import qualified HaskellWorks.Data.Json.Backend.Standard.SemiIndex as STSI-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.Blank as J-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.BlankedJson as J-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.MakeIndex as J-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.ToBalancedParens64 as J-import qualified HaskellWorks.Data.Json.Simd.Index.Standard as STSI-import qualified System.Exit as IO-import qualified System.IO as IO-import qualified System.IO.MMap as IO+import qualified App.Commands.Types as Z+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BSI+import qualified Data.ByteString.Lazy as LBS+import qualified HaskellWorks.Data.ByteString as BS+import qualified HaskellWorks.Data.ByteString.Lazy as LBS+#if x86_64_HOST_ARCH+import qualified HaskellWorks.Data.Json.Simd.Index.Standard as STSI+#endif+import qualified HaskellWorks.Data.Json.Simple.Cursor.SemiIndex as SISI+import qualified HaskellWorks.Data.Json.Standard.Cursor.Internal.Blank as J+import qualified HaskellWorks.Data.Json.Standard.Cursor.Internal.BlankedJson as J+import qualified HaskellWorks.Data.Json.Standard.Cursor.Internal.MakeIndex as J+import qualified HaskellWorks.Data.Json.Standard.Cursor.Internal.ToBalancedParens64 as J+import qualified HaskellWorks.Data.Json.Standard.Cursor.SemiIndex as STSI+import qualified System.Exit as IO+import qualified System.IO as IO+import qualified System.IO.MMap as IO -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}-{-# ANN module ("HLint: ignore Redundant do" :: String) #-}+{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant do" -} runCreateIndexStandard :: Z.CreateIndexOptions -> IO ()+#if x86_64_HOST_ARCH runCreateIndexStandard opts = do let filePath = opts ^. the @"filePath" let outputIbFile = opts ^. the @"outputIbFile" & fromMaybe (filePath <> ".ib.idx")@@ -81,8 +84,12 @@ unknown -> do IO.hPutStrLn IO.stderr $ "Unknown method " <> show unknown IO.exitFailure+#else+runCreateIndexStandard opts = undefined+#endif runCreateIndexSimple :: Z.CreateIndexOptions -> IO ()+#if x86_64_HOST_ARCH runCreateIndexSimple opts = do let filePath = opts ^. the @"filePath" let outputIbFile = opts ^. the @"outputIbFile" & fromMaybe (filePath <> ".ib.idx")@@ -92,6 +99,9 @@ let SISI.SemiIndex _ ibs bps = SISI.buildSemiIndex bs LBS.writeFile outputIbFile (LBS.toLazyByteString ibs) LBS.writeFile outputBpFile (LBS.toLazyByteString bps)+#else+runCreateIndexSimple opts = undefined+#endif runCreateIndex :: Z.CreateIndexOptions -> IO () runCreateIndex opts = case opts ^. the @"backend" of
app/App/Commands/Demo.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -10,58 +11,36 @@ import Control.Lens import Control.Monad-import Control.Monad.ST import Data.Generics.Product.Any-import Data.Semigroup ((<>)) import Data.Word import Foreign.ForeignPtr-import HaskellWorks.Data.BalancedParens.Simple-import HaskellWorks.Data.Json.Backend.Standard.Cursor-import HaskellWorks.Data.Json.Backend.Standard.Load.Cursor import HaskellWorks.Data.Json.LightJson import HaskellWorks.Data.Json.Query+import HaskellWorks.Data.Json.Standard.Cursor.Generic+import HaskellWorks.Data.Json.Standard.Cursor.Load.Cursor import HaskellWorks.Data.MQuery import HaskellWorks.Data.MQuery.Micro import HaskellWorks.Data.RankSelect.CsPoppy-import HaskellWorks.Data.Vector.AsVector8-import Options.Applicative hiding (columns)+import HaskellWorks.Data.Vector.Storable+import Options.Applicative hiding (columns) import qualified App.Commands.Types as Z-import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI import qualified Data.ByteString.Lazy as LBS import qualified Data.DList as DL-import qualified Data.Vector.Storable as DVS-import qualified Data.Vector.Storable.Mutable as DVSM+import qualified HaskellWorks.Data.BalancedParens.RangeMin as RM import qualified HaskellWorks.Data.ByteString.Lazy as LBS+#if x86_64_HOST_ARCH import qualified HaskellWorks.Data.Json.Simd.Index.Standard as S+#endif import qualified Options.Applicative as OA import qualified System.IO as IO import qualified System.IO.MMap as IO -constructUnzipN :: Int -> [(BS.ByteString, BS.ByteString)] -> (DVS.Vector Word64, DVS.Vector Word64)-constructUnzipN nBytes xs = (DVS.unsafeCast ibv, DVS.unsafeCast bpv)- where [ibv, bpv] = DVS.createT $ do- let nW64s = (nBytes + 7) `div` 8- let capacity = nW64s * 8- ibmv <- DVSM.new capacity- bpmv <- DVSM.new capacity- (ibmvRemaining, bpmvRemaining) <- go ibmv bpmv xs- return- [ DVSM.take (((DVSM.length ibmv - ibmvRemaining) `div` 8) * 8) ibmv- , DVSM.take (((DVSM.length bpmv - bpmvRemaining) `div` 8) * 8) bpmv- ]- go :: DVSM.MVector s Word8 -> DVSM.MVector s Word8 -> [(BS.ByteString, BS.ByteString)] -> ST s (Int, Int)- go ibmv bpmv ((ib, bp):ys) = do- DVS.copy (DVSM.take (BS.length ib) ibmv) (asVector8 ib)- DVS.copy (DVSM.take (BS.length bp) bpmv) (asVector8 bp)- go (DVSM.drop (BS.length ib) ibmv) (DVSM.drop (BS.length bp) bpmv) ys- go ibmv bpmv [] = do- DVSM.set (DVSM.take 8 ibmv) 0- DVSM.set (DVSM.take 8 bpmv) 0- return (DVSM.length (DVSM.drop 8 ibmv), DVSM.length (DVSM.drop 8 bpmv))+{- HLINT ignore "Reduce duplication" -} runDemo :: Z.DemoOptions -> IO ()+#if x86_64_HOST_ARCH runDemo opts = do let filePath = opts ^. the @"filePath" case opts ^. the @"method" of@@ -76,15 +55,17 @@ let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size case S.makeStandardJsonIbBps (LBS.resegmentPadded 512 (LBS.fromStrict bs)) of Right ibBps -> do- let (!ib, !bp) = constructUnzipN size ibBps- let !cursor = JsonCursor bs (makeCsPoppy ib) (SimpleBalancedParens bp) 1+ let (!ib, !bp) = construct64UnzipN size ibBps+ let !cursor = GenericCursor bs (makeCsPoppy ib) (RM.mkRangeMin bp) 1 let !json = lightJsonAt cursor let q = MQuery (DL.singleton json) putPretty $ q >>= (entry >=> named "meta" >=> entry >=> named "view" >=> entry >=> named "columns" >=> item >=> entry >=> named "id") & count Left msg -> IO.hPutStrLn IO.stderr $ "Unable to create semi-index: " <> show msg m -> IO.hPutStrLn IO.stderr $ "Unrecognised method: " <> show m-+#else+runDemo opts = undefined+#endif optsDemo :: Parser Z.DemoOptions optsDemo = Z.DemoOptions
app/App/Commands/Types.hs view
@@ -2,10 +2,14 @@ {-# LANGUAGE DuplicateRecordFields #-} module App.Commands.Types- ( CreateIndexOptions(..)+ ( CountAesonOptions(..)+ , CountOptions(..)+ , CreateIndexOptions(..) , DemoOptions(..)+ , FileIndexes(..) ) where +import Data.Text (Text) import GHC.Generics data CreateIndexOptions = CreateIndexOptions@@ -19,4 +23,20 @@ data DemoOptions = DemoOptions { filePath :: FilePath , method :: FilePath+ } deriving (Eq, Show, Generic)++data CountOptions = CountOptions+ { inputFile :: FilePath+ , indexes :: Maybe FileIndexes+ , expression :: Text+ } deriving (Eq, Show, Generic)++data CountAesonOptions = CountAesonOptions+ { inputFile :: FilePath+ , expression :: Text+ } deriving (Eq, Show, Generic)++data FileIndexes = FileIndexes+ { ibIndex :: FilePath+ , bpIndex :: FilePath } deriving (Eq, Show, Generic)
app/Main.hs view
@@ -2,7 +2,6 @@ import App.Commands import Control.Monad-import Data.Semigroup ((<>)) import Options.Applicative main :: IO ()
bench/Main.hs view
@@ -1,74 +1,10 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where -import Control.Monad import Criterion.Main-import Data.List-import Data.Word-import Foreign-import HaskellWorks.Data.Json.Internal.Backend.Standard.Blank-import HaskellWorks.Data.Json.Internal.Backend.Standard.MakeIndex-import System.IO.MMap -import qualified Data.ByteString as BS-import qualified Data.ByteString.Internal as BSI-import qualified HaskellWorks.Data.Json.Backend.Standard.Fast as FAST-import qualified HaskellWorks.Data.Json.Backend.Standard.Slow as SLOW-import qualified System.Directory as IO--setupEnvJson :: FilePath -> IO BS.ByteString-setupEnvJson filepath = do- (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr filepath ReadOnly Nothing- let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size- return bs--jsonToInterestBits3 :: [BS.ByteString] -> [BS.ByteString]-jsonToInterestBits3 = blankedJsonToInterestBits . blankJson--makeBenchBlankJson :: IO [Benchmark]-makeBenchBlankJson = do- entries <- IO.listDirectory "corpus/bench"- let files = ("corpus/bench/" ++) <$> (".json" `isSuffixOf`) `filter` entries- benchmarks <- forM files $ \file -> return- [ env (setupEnvJson file) $ \bs -> bgroup file- [ bench "Run blankJson" (whnf (BS.concat . blankJson) [bs])- ]- ]-- return (join benchmarks)--makeBenchJsonToInterestBits :: IO [Benchmark]-makeBenchJsonToInterestBits = do- entries <- IO.listDirectory "corpus/bench"- let files = ("corpus/bench/" ++) <$> (".json" `isSuffixOf`) `filter` entries- benchmarks <- forM files $ \file -> return- [ env (setupEnvJson file) $ \bs -> bgroup file- [ bench "Run blankJson" (whnf (BS.concat . jsonToInterestBits3) [bs])- ]- ]-- return (join benchmarks)--makeBenchMakeCursor :: IO [Benchmark]-makeBenchMakeCursor = do- entries <- IO.listDirectory "corpus/bench"- let files = ("corpus/bench/" ++) <$> (".json" `isSuffixOf`) `filter` entries- benchmarks <- forM files $ \file -> return- [ env (setupEnvJson file) $ \bs -> bgroup file- [ bench "Run slow make cursor" (whnf SLOW.makeCursor bs)- , bench "Run fast make cursor" (whnf FAST.makeCursor bs)- ]- ]-- return (join benchmarks)- main :: IO () main = do- benchmarks <- mconcat <$> sequence- [ makeBenchBlankJson- , makeBenchJsonToInterestBits- , makeBenchMakeCursor- ]+ benchmarks <- mconcat <$> sequence mempty defaultMain benchmarks
+ doctest/DoctestDriver.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE CPP #-}++#if MIN_VERSION_GLASGOW_HASKELL(8,4,4,0)+{-# OPTIONS_GHC -F -pgmF doctest-discover #-}+#else+module Main where++import qualified System.IO as IO++main :: IO ()+main = IO.putStrLn "WARNING: doctest will not run on GHC versions earlier than 8.4.4"+#endif
+ examples/Example1.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-local-binds #-}++module Example1 where++import Data.Aeson++import qualified Data.ByteString.Lazy as LBS++example :: IO ()+example = do+ !bs <- LBS.readFile "corpus/bench/hospitalisation.json"+ let !y = decode bs :: Maybe Value+ return ()
+ examples/Example2.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-local-binds #-}++module Example2 where++import qualified HaskellWorks.Data.ByteString as BS+import qualified HaskellWorks.Data.Json.Standard.Cursor.Fast as JCF++example :: IO ()+example = do+ !jsonBs <- BS.mmap "corpus/bench/hospitalisation.json"+ let !ibip = JCF.simdToIbBp jsonBs+ let !c = JCF.fromBsIbBp jsonBs ibip+ return ()
+ examples/Example3.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-local-binds #-}++module Example3 where++import Control.Monad++import qualified Data.ByteString as BS+import qualified HaskellWorks.Data.Json.Standard.Cursor.Fast as JCF+import qualified HaskellWorks.Data.TreeCursor as TC++example :: IO ()+example = do+ let fc = TC.firstChild+ let ns = TC.nextSibling+ let jsonBs = "[null, {\"field\": 1}]" :: BS.ByteString+ let ibip = JCF.simdToIbBp jsonBs+ let cursor = JCF.fromBsIbBp jsonBs ibip+ let _ = fc cursor+ let _ = (fc >=> ns) cursor+ return ()
+ examples/Example4.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-local-binds #-}++module Example4 where++import Control.Monad+import Data.Function+import Data.List+import HaskellWorks.Data.Json.PartialValue+import HaskellWorks.Data.Json.Standard.Cursor.Load.Cursor+import HaskellWorks.Data.Json.Standard.Load.Partial+import HaskellWorks.Data.MQuery+import HaskellWorks.Data.MQuery.Micro++import qualified Data.DList as DL++{- HLINT ignore "Reduce duplication" -}++example :: IO ()+example = do+ !cursor <- loadPartial "corpus/bench/78mb.json"+ !cursor <- loadCursorWithIndex "corpus/bench/78mb.json"+ !cursor <- loadCursor "corpus/bench/78mb.json"+ !cursor <- loadCursorWithCsPoppyIndex "corpus/bench/78mb.json"+ let !json = jsonPartialJsonValueAt cursor+ let q = MQuery (DL.singleton json)++ putPretty $ q >>= item & limit 10+ putPretty $ q >>= item & page 10 1+ putPretty $ q >>= item >>= hasKV "founded_year" (JsonPartialNumber 2005) & limit 10+ putPretty $ q >>= item >>= entry+ putPretty $ q >>= item >>= entry >>= named "name" & limit 10+ putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> entry >=> named "price_currency_code")+ putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> entry >=> named "price_currency_code") & onList (uniq . sort)+ putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> entry >=> named "price_currency_code" >=> asString >=> valueOf "USD") & limit 10+ putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> having (entry >=> named "price_currency_code" >=> asString >=> valueOf "USD") >=> entry >=> named "price_amount") & limit 10+ putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> having (entry >=> named "price_currency_code" >=> asString >=> valueOf "USD") >=> entry >=> named "price_amount" >=> castAsInteger ) & limit 10+ putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> having (entry >=> named "price_currency_code" >=> asString >=> valueOf "USD") >=> entry >=> named "price_amount" >=> castAsInteger ) & aggregate sum++ putPretty $ q >>= item & limit 10+ putPretty $ q >>= item & page 10 1+ putPretty $ q >>= item >>= entry+ putPretty $ q >>= item >>= entry >>= named "name" & limit 10+ putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> entry >=> named "price_currency_code" >=> asString)+ putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> entry >=> named "price_currency_code" >=> asString) & onList (uniq . sort)+ putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> entry >=> named "price_currency_code" >=> asString >=> valueOf "USD") & limit 10+ putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> having (entry >=> named "price_currency_code" >=> asString >=> valueOf "USD") >=> entry >=> named "price_amount") & limit 10+ putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> having (entry >=> named "price_currency_code" >=> asString >=> valueOf "USD") >=> entry >=> named "price_amount" >=> castAsInteger ) & limit 10+ putPretty $ q >>= (item >=> entry >=> named "acquisition" >=> having (entry >=> named "price_currency_code" >=> asString >=> valueOf "USD") >=> entry >=> named "price_amount" >=> castAsInteger ) & aggregate sum++ return ()
hw-json.cabal view
@@ -1,222 +1,248 @@ cabal-version: 2.2 -name: hw-json-version: 1.0.0.2-synopsis: Memory efficient JSON parser-description: Memory efficient JSON parser. Please see README.md-category: Data-homepage: http://github.com/haskell-works/hw-json#readme-bug-reports: https://github.com/haskell-works/hw-json/issues-author: John Ky-maintainer: newhoggy@gmail.com-copyright: 2016 - 2019 John Ky-license: BSD-3-Clause-license-file: LICENSE-build-type: Simple-extra-source-files:- README.md- corpus/5000B.json- corpus/5000B.json.bp.idx- corpus/5000B.json.ib.idx- corpus/issue-0001.json- corpus/issue-0001.json.bp.idx- corpus/issue-0001.json.ib.idx- corpus/issue-0001.md+name: hw-json+version: 1.3.3.1+synopsis: Memory efficient JSON parser+description: Memory efficient JSON parser. Please see README.md+category: Data+homepage: http://github.com/haskell-works/hw-json#readme+bug-reports: https://github.com/haskell-works/hw-json/issues+author: John Ky+maintainer: newhoggy@gmail.com+copyright: 2016-2025 John Ky+license: BSD-3-Clause+license-file: LICENSE+tested-with: GHC == 9.12.2, GHC == 9.10.2, GHC == 9.8.4, GHC == 9.6.7+build-type: Simple+extra-source-files: README.md+ corpus/5000B.json+ corpus/5000B.json.bp.idx+ corpus/5000B.json.ib.idx+ corpus/issue-0001.json+ corpus/issue-0001.json.bp.idx+ corpus/issue-0001.json.ib.idx+ corpus/issue-0001.md source-repository head type: git location: https://github.com/haskell-works/hw-json flag bmi2- description: Enable bmi2 instruction set- manual: False- default: False+ description: Enable bmi2 instruction set+ manual: False+ default: False flag sse42- description: Enable sse4.2 instruction set- manual: False- default: False--common base { build-depends: base >= 4 && < 5 }+ description: Enable sse4.2 instruction set+ manual: False+ default: False -common ansi-wl-pprint { build-depends: ansi-wl-pprint >= 0.6.8.2 && < 0.7 }-common array { build-depends: array >= 0.5 && < 0.6 }-common attoparsec { build-depends: attoparsec >= 0.13 && < 0.14 }-common bits-extra { build-depends: bits-extra >= 0.0.1 && < 0.1 }-common bytestring { build-depends: bytestring >= 0.10.6 && < 0.11 }-common criterion { build-depends: criterion >= 1.4 && < 1.6 }-common directory { build-depends: directory >= 1.3 && < 1.4 }-common dlist { build-depends: dlist >= 0.8 && < 0.9 }-common generic-lens { build-depends: generic-lens >= 1.1.0.0 && < 1.2 }-common hedgehog { build-depends: hedgehog >= 0.5 && < 0.7 }-common hspec { build-depends: hspec >= 2.4 && < 3 }-common hw-balancedparens { build-depends: hw-balancedparens >= 0.2.0.1 && < 0.3 }-common hw-bits { build-depends: hw-bits >= 0.7.0.5 && < 0.8 }-common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1.0.4 && < 0.2 }-common hw-json-simd { build-depends: hw-json-simd >= 0.1.0.2 && < 0.2 }-common hw-mquery { build-depends: hw-mquery >= 0.2.0.0 && < 0.3 }-common hw-parser { build-depends: hw-parser >= 0.1 && < 0.2 }-common hw-prim { build-depends: hw-prim >= 0.6.2.21 && < 0.7 }-common hw-rankselect { build-depends: hw-rankselect >= 0.13 && < 0.14 }-common hw-rankselect-base { build-depends: hw-rankselect-base >= 0.3.2.1 && < 0.4 }-common hw-simd { build-depends: hw-simd >= 0.1.1.2 && < 0.2 }-common lens { build-depends: lens >= 4 && < 5 }-common mmap { build-depends: mmap >= 0.5 && < 0.6 }-common optparse-applicative { build-depends: optparse-applicative >= 0.14 && < 0.15 }-common text { build-depends: text >= 1.2 && < 1.3 }-common transformers { build-depends: transformers >= 0.4 && < 0.6 }-common vector { build-depends: vector >= 0.12 && < 0.13 }-common word8 { build-depends: word8 >= 0.1 && < 0.2 }+common base { build-depends: base >= 4.11 && < 5 } -common semigroups { if impl(ghc < 8 ) { build-depends: semigroups >= 0.16 && < 0.19 } }+common aeson { build-depends: aeson >= 2.0 && < 2.3 }+common array { build-depends: array >= 0.5 && < 0.6 }+common attoparsec { build-depends: attoparsec >= 0.13 && < 0.15 }+common attoparsec-aeson { build-depends: attoparsec-aeson >= 2 && < 3 }+common bits-extra { build-depends: bits-extra >= 0.0.1.3 && < 0.1 }+common bytestring { build-depends: bytestring >= 0.10.6 && < 0.13 }+common criterion { build-depends: criterion >= 1.4 && < 1.7 }+common directory { build-depends: directory >= 1.3 && < 1.4 }+common dlist { build-depends: dlist >= 0.8 && < 1.1 }+common doctest { build-depends: doctest >= 0.16.2 && < 1 }+common doctest-discover { build-depends: doctest-discover >= 0.2 && < 0.3 }+common generic-lens { build-depends: generic-lens >= 1.2.0.1 && < 2.3 }+common hedgehog { build-depends: hedgehog >= 0.6 && < 2 }+common hspec { build-depends: hspec >= 2.4 && < 3 }+common hw-balancedparens { build-depends: hw-balancedparens >= 0.3.0.0 && < 0.5 }+common hw-bits { build-depends: hw-bits >= 0.7.0.5 && < 0.8 }+common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1.0.4 && < 0.2 }+common hw-json-simd {+ if arch(x86_64)+ build-depends: hw-json-simd >= 0.1.0.2 && < 0.2+}+common hw-json-simple-cursor { build-depends: hw-json-simple-cursor >= 0.1.0.1 && < 0.2 }+common hw-json-standard-cursor { build-depends: hw-json-standard-cursor >= 0.2.0.1 && < 0.3 }+common hw-mquery { build-depends: hw-mquery >= 0.2.0.0 && < 0.3 }+common hw-parser { build-depends: hw-parser >= 0.1 && < 0.2 }+common hw-prim { build-depends: hw-prim >= 0.6.2.32 && < 0.7 }+common hw-rankselect { build-depends: hw-rankselect >= 0.13 && < 0.14 }+common hw-rankselect-base { build-depends: hw-rankselect-base >= 0.3.2.1 && < 0.4 }+common hw-simd {+ if arch(x86_64)+ build-depends: hw-simd >= 0.1.1.2 && < 0.2+}+common lens { build-depends: lens >= 4 && < 6 }+common mmap { build-depends: mmap >= 0.5 && < 0.6 }+common optparse-applicative { build-depends: optparse-applicative >= 0.14 && < 0.19 }+common prettyprinter { build-depends: prettyprinter >= 1 && < 2 }+common scientific { build-depends: scientific >= 0.3.6.2 && < 0.4 }+common text { build-depends: text >= 1.2 && < 3 }+common transformers { build-depends: transformers >= 0.4 && < 0.7 }+common unordered-containers { build-depends: unordered-containers >= 0.2 && < 0.3 }+common vector { build-depends: vector >= 0.12 && < 0.14 }+common word8 { build-depends: word8 >= 0.1 && < 0.2 } common config- default-language: Haskell2010- ghc-options: -Wall+ default-language: Haskell2010+ ghc-options: -Wall -O2 -msse4.2 if flag(sse42)- ghc-options: -mbmi2+ ghc-options: -msse4.2 if flag(bmi2) && impl(ghc >= 8.4.1)- ghc-options: -mbmi2 -msse4.2- cpp-options: -DBMI2_ENABLED+ ghc-options: -mbmi2 -msse4.2+ cpp-options: -DBMI2_ENABLED +common hw-json+ build-depends: hw-json+ library- import: base, config- , ansi-wl-pprint- , array- , attoparsec- , bits-extra- , bytestring- , dlist- , hw-balancedparens- , hw-bits- , hw-mquery- , hw-parser- , hw-prim- , hw-rankselect- , hw-rankselect-base- , hw-simd- , mmap- , semigroups- , text- , vector- , word8- hs-source-dirs: src- ghc-options: -O2 -msse4.2- other-modules: Paths_hw_json- autogen-modules: Paths_hw_json- exposed-modules:- HaskellWorks.Data.Json- HaskellWorks.Data.Json.Backend.Simple.Cursor- HaskellWorks.Data.Json.Backend.Simple.Fast- HaskellWorks.Data.Json.Backend.Simple.SemiIndex- HaskellWorks.Data.Json.Backend.Simple.Value- HaskellWorks.Data.Json.Backend.Standard.Cursor- HaskellWorks.Data.Json.Backend.Standard.Fast- HaskellWorks.Data.Json.Backend.Standard.Index- HaskellWorks.Data.Json.Backend.Standard.Load.Cursor- HaskellWorks.Data.Json.Backend.Standard.Load.Partial- HaskellWorks.Data.Json.Backend.Standard.Load.Raw- HaskellWorks.Data.Json.Backend.Standard.SemiIndex- HaskellWorks.Data.Json.Backend.Standard.Slow- HaskellWorks.Data.Json.DecodeError- HaskellWorks.Data.Json.FromValue- HaskellWorks.Data.Json.Internal.Backend.Standard.Blank- HaskellWorks.Data.Json.Internal.Backend.Standard.BlankedJson- HaskellWorks.Data.Json.Internal.Backend.Standard.Cursor.Token- HaskellWorks.Data.Json.Internal.Backend.Standard.IbBp- HaskellWorks.Data.Json.Internal.Backend.Standard.MakeIndex- HaskellWorks.Data.Json.Internal.Backend.Standard.StateMachine- HaskellWorks.Data.Json.Internal.Backend.Standard.ToBalancedParens64- HaskellWorks.Data.Json.Internal.Backend.Standard.ToInterestBits64- HaskellWorks.Data.Json.Internal.Backend.Standard.Token.Tokenize- HaskellWorks.Data.Json.Internal.Backend.Simple.IbBp- HaskellWorks.Data.Json.Internal.Backend.Simple.ToIbBp- HaskellWorks.Data.Json.Internal.CharLike- HaskellWorks.Data.Json.Internal.Doc- HaskellWorks.Data.Json.Internal.Index- HaskellWorks.Data.Json.Internal.PartialIndex- HaskellWorks.Data.Json.Internal.Slurp- HaskellWorks.Data.Json.Internal.Token- HaskellWorks.Data.Json.Internal.Token.Types- HaskellWorks.Data.Json.Internal.Value- HaskellWorks.Data.Json.Internal.Word64- HaskellWorks.Data.Json.Internal.Word8- HaskellWorks.Data.Json.LightJson- HaskellWorks.Data.Json.PartialValue- HaskellWorks.Data.Json.Query- HaskellWorks.Data.Json.Type- HaskellWorks.Data.Json.Value+ import: base, config+ , aeson+ , attoparsec+ , attoparsec-aeson+ , bits-extra+ , bytestring+ , dlist+ , hw-balancedparens+ , hw-bits+ , hw-json-simple-cursor+ , hw-json-standard-cursor+ , hw-mquery+ , hw-parser+ , hw-prim+ , hw-rankselect+ , hw-rankselect-base+ , hw-simd+ , mmap+ , prettyprinter+ , scientific+ , text+ , vector+ , word8+ hs-source-dirs: src+ other-modules: Paths_hw_json+ autogen-modules: Paths_hw_json+ exposed-modules: HaskellWorks.Data.Json.DecodeError+ HaskellWorks.Data.Json.FromValue+ HaskellWorks.Data.Json.Internal.CharLike+ HaskellWorks.Data.Json.Internal.Doc+ HaskellWorks.Data.Json.Internal.Index+ HaskellWorks.Data.Json.Internal.PartialIndex+ HaskellWorks.Data.Json.Internal.Slurp+ HaskellWorks.Data.Json.Internal.Standard.Cursor.Token+ HaskellWorks.Data.Json.Internal.Standard.Token.Tokenize+ HaskellWorks.Data.Json.Internal.Token+ HaskellWorks.Data.Json.Internal.Token.Types+ HaskellWorks.Data.Json.Internal.Value+ HaskellWorks.Data.Json.Internal.Word64+ HaskellWorks.Data.Json.LightJson+ HaskellWorks.Data.Json.PartialValue+ HaskellWorks.Data.Json.Query+ HaskellWorks.Data.Json.Simple.Value+ HaskellWorks.Data.Json.Standard.Load.Partial+ HaskellWorks.Data.Json.Value executable hw-json- import: base, config- , bytestring- , dlist- , generic-lens- , hw-balancedparens- , hw-json-simd- , hw-mquery- , hw-prim- , hw-rankselect- , hw-rankselect-base- , lens- , mmap- , optparse-applicative- , semigroups- , vector- main-is: Main.hs- hs-source-dirs: app- ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -msse4.2- build-depends: hw-json- other-modules:- App.Commands- App.Commands.CreateIndex- App.Commands.Demo- App.Commands.Types+ import: base, config+ , aeson+ , bytestring+ , dlist+ , generic-lens+ , hw-balancedparens+ , hw-json+ , hw-json-simd+ , hw-json-simple-cursor+ , hw-json-standard-cursor+ , hw-mquery+ , hw-prim+ , hw-rankselect+ , hw-rankselect-base+ , lens+ , mmap+ , optparse-applicative+ , text+ , unordered-containers+ , vector+ main-is: Main.hs+ hs-source-dirs: app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ other-modules: App.Commands+ App.Commands.CreateIndex+ App.Commands.Count+ App.Commands.CountAeson+ App.Commands.Demo+ App.Commands.Types test-suite hw-json-test- import: base, config- , attoparsec- , bytestring- , hedgehog- , hspec- , hw-balancedparens- , hw-bits- , hw-hspec-hedgehog- , hw-prim- , hw-rankselect- , hw-rankselect-base- , transformers- , vector- type: exitcode-stdio-1.0- main-is: Spec.hs- build-depends: hw-json- hs-source-dirs: test- ghc-options: -threaded -rtsopts -with-rtsopts=-N- build-tools: hspec-discover- other-modules:- HaskellWorks.Data.Json.Backend.Simple.CursorSpec- HaskellWorks.Data.Json.Backend.Standard.Succinct.Cursor.BalancedParensSpec- HaskellWorks.Data.Json.Backend.Standard.Succinct.Cursor.InterestBitsSpec- HaskellWorks.Data.Json.Backend.Standard.Succinct.CursorSpec- HaskellWorks.Data.Json.Backend.Standard.Succinct.GenCursorTest- HaskellWorks.Data.Json.CorpusSpec- HaskellWorks.Data.Json.Internal.BlankSpec- HaskellWorks.Data.Json.Succinct.Cursor.BalancedParensSpec- HaskellWorks.Data.Json.Token.TokenizeSpec- HaskellWorks.Data.Json.TypeSpec- HaskellWorks.Data.Json.ValueSpec- Paths_hw_json+ import: base, config+ , aeson+ , attoparsec+ , attoparsec-aeson+ , bytestring+ , dlist+ , hedgehog+ , hspec+ , hw-balancedparens+ , hw-bits+ , hw-hspec-hedgehog+ , hw-json+ , hw-json-simple-cursor+ , hw-json-standard-cursor+ , hw-mquery+ , hw-prim+ , hw-rankselect+ , hw-rankselect-base+ , scientific+ , text+ , transformers+ , vector+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-tool-depends: hspec-discover:hspec-discover+ other-modules: HaskellWorks.Data.Json.LightJsonSpec+ HaskellWorks.Data.Json.Simple.CursorSpec+ HaskellWorks.Data.Json.Standard.CursorSpec+ HaskellWorks.Data.Json.Standard.GenCursorTest+ HaskellWorks.Data.Json.Token.TokenizeSpec+ HaskellWorks.Data.Json.TypeSpec+ HaskellWorks.Data.Json.ValueSpec +library examples+ import: base, config+ , aeson+ , bytestring+ , dlist+ , hw-json+ , hw-json-standard-cursor+ , hw-mquery+ , hw-prim+ hs-source-dirs: examples+ other-modules: Example1+ Example2+ Example3+ Example4+ benchmark bench- import: base, config- , bytestring- , criterion- , directory- , mmap- , semigroups- type: exitcode-stdio-1.0- main-is: Main.hs- hs-source-dirs: bench- ghc-options: -O2 -msse4.2- build-depends: hw-json- other-modules: Paths_hw_json+ import: base, config+ , bytestring+ , criterion+ , directory+ , hw-json+ , hw-json-standard-cursor+ , mmap+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench++test-suite doctest+ import: base, config+ , doctest+ , doctest-discover+ , hw-json+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ main-is: DoctestDriver.hs+ HS-Source-Dirs: doctest+ build-tool-depends: doctest-discover:doctest-discover
− src/HaskellWorks/Data/Json.hs
@@ -1,11 +0,0 @@--- |--- Copyright: 2016 John Ky--- License: MIT------ Json-module HaskellWorks.Data.Json- ( module X- ) where--import HaskellWorks.Data.Json.Type as X-import HaskellWorks.Data.Json.Value as X
− src/HaskellWorks/Data/Json/Backend/Simple/Cursor.hs
@@ -1,89 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}--module HaskellWorks.Data.Json.Backend.Simple.Cursor- ( JsonCursor(..)- , jsonCursorPos- ) where--import Data.String-import Data.Word-import HaskellWorks.Data.FromByteString-import HaskellWorks.Data.FromForeignRegion-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.RankSelect.Poppy512-import HaskellWorks.Data.TreeCursor-import Prelude hiding (drop)--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.Internal as BSI-import qualified Data.Vector.Storable as DVS-import qualified Foreign.ForeignPtr as F-import qualified HaskellWorks.Data.BalancedParens as BP-import qualified HaskellWorks.Data.Json.Backend.Simple.SemiIndex as SI--data JsonCursor t v w = JsonCursor- { cursorText :: !t- , interests :: !v- , balancedParens :: !w- , cursorRank :: !Count- }- deriving (Eq, Show)--instance FromByteString (JsonCursor BS.ByteString (DVS.Vector Word64) (BP.SimpleBalancedParens (DVS.Vector Word64))) where- fromByteString bs = JsonCursor- { cursorText = bs- , interests = ib- , balancedParens = BP.SimpleBalancedParens bp- , cursorRank = 1- }- where SI.SemiIndex _ ib bp = SI.buildSemiIndex bs--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- }- where SI.SemiIndex _ ib bp = SI.buildSemiIndex bs--instance FromForeignRegion (JsonCursor BS.ByteString (DVS.Vector Word64) (BP.SimpleBalancedParens (DVS.Vector Word64))) where- fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (F.castForeignPtr fptr) offset size)--instance FromForeignRegion (JsonCursor BS.ByteString Poppy512 (BP.SimpleBalancedParens (DVS.Vector Word64))) where- fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (F.castForeignPtr fptr) offset size)--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 (BP.BalancedParens u, Rank1 u, Rank0 u) => TreeCursor (JsonCursor t v u) where- firstChild :: JsonCursor t v u -> Maybe (JsonCursor t v u)- firstChild k = let mq = BP.firstChild (balancedParens k) (cursorRank k) in (\q -> k { cursorRank = q }) <$> mq-- nextSibling :: JsonCursor t v u -> Maybe (JsonCursor t v u)- nextSibling k = (\q -> k { cursorRank = q }) <$> BP.nextSibling (balancedParens k) (cursorRank k)-- parent :: JsonCursor t v u -> Maybe (JsonCursor t v u)- parent k = let mq = BP.parent (balancedParens k) (cursorRank k) in (\q -> k { cursorRank = q }) <$> mq-- depth :: JsonCursor t v u -> Maybe Count- depth k = BP.depth (balancedParens k) (cursorRank k)-- subtreeSize :: JsonCursor t v u -> Maybe Count- subtreeSize k = BP.subtreeSize (balancedParens k) (cursorRank k)--jsonCursorPos :: (Rank1 w, Select1 v) => JsonCursor s v w -> Position-jsonCursorPos k = toPosition (select1 ik (rank1 bpk (cursorRank k)) - 1)- where ik = interests k- bpk = balancedParens k
− src/HaskellWorks/Data/Json/Backend/Simple/Fast.hs
@@ -1,38 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}--module HaskellWorks.Data.Json.Backend.Simple.Fast- ( makeCursor- ) where--import Data.Word-import Foreign.ForeignPtr-import HaskellWorks.Data.FromForeignRegion-import HaskellWorks.Data.Json.Backend.Simple.Cursor-import HaskellWorks.Data.RankSelect.Poppy512--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.Internal as BSI-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.BalancedParens as BP-import qualified HaskellWorks.Data.Json.Internal.Backend.Simple.IbBp as J-import qualified HaskellWorks.Data.Json.Internal.Backend.Simple.ToIbBp as J--class MakeCursor a where- makeCursor :: a -> JsonCursor BS.ByteString Poppy512 (BP.SimpleBalancedParens (DVS.Vector Word64))--instance MakeCursor BS.ByteString where- makeCursor bs = JsonCursor- { cursorText = bs- , interests = makePoppy512 ib- , balancedParens = BP.SimpleBalancedParens bp- , cursorRank = 1- }- where J.IbBp ib bp = J.toIbBp bs--instance MakeCursor String where- makeCursor = makeCursor . BSC.pack--instance MakeCursor ForeignRegion where- makeCursor (fptr, offset, size) = makeCursor (BSI.fromForeignPtr (castForeignPtr fptr) offset size)
− src/HaskellWorks/Data/Json/Backend/Simple/SemiIndex.hs
@@ -1,80 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiWayIf #-}--module HaskellWorks.Data.Json.Backend.Simple.SemiIndex- ( buildSemiIndex- , SemiIndex(..)- ) where--import Control.Monad.ST-import Data.Word--import qualified Data.ByteString as BS-import qualified Data.ByteString.Unsafe as BSU-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.Bits.Writer.Storable as W-import qualified HaskellWorks.Data.Json.Internal.Word8 as W8--{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}-{-# ANN module ("HLint: ignore Redundant do" :: String) #-}--data Context = InJson | InString | InEscape deriving (Eq, Show)--data SemiIndex v = SemiIndex- { semiIndexContext :: !Context- , semiIndexIb :: !v- , semiIndexBp :: !v- } deriving (Functor, Traversable, Foldable)--buildSemiIndex :: BS.ByteString -> SemiIndex (DVS.Vector Word64)-buildSemiIndex bs = DVS.createT $ do- let len = (BS.length bs + 7) `div` 8- mib <- W.newWriter len- mbp <- W.newWriter (len * 2)- buildFromByteString mib mbp bs 0 InJson-{-# INLINE buildSemiIndex #-}--buildFromByteString :: W.Writer s -> W.Writer s -> BS.ByteString -> Int -> Context -> ST s (SemiIndex (DVS.MVector s Word64))-buildFromByteString ib bp bs i context = if i < BS.length bs- then do- let c = BSU.unsafeIndex bs i- case context of- InJson -> if- | c == W8.openBracket || c == W8.openBrace -> do- W.unsafeWriteBit bp 1- W.unsafeWriteBit bp 1- W.unsafeWriteBit ib 1- buildFromByteString ib bp bs (i + 1) InJson- | c == W8.closeBracket || c == W8.closeBrace -> do- W.unsafeWriteBit bp 0- W.unsafeWriteBit bp 0- W.unsafeWriteBit ib 1- buildFromByteString ib bp bs (i + 1) InJson- | c == W8.comma || c == W8.colon -> do- W.unsafeWriteBit bp 0- W.unsafeWriteBit bp 1- W.unsafeWriteBit ib 1- buildFromByteString ib bp bs (i + 1) InJson- | c == W8.doubleQuote -> do- W.unsafeWriteBit ib 0- buildFromByteString ib bp bs (i + 1) InString- | otherwise -> do- W.unsafeWriteBit ib 0- buildFromByteString ib bp bs (i + 1) InJson- InString -> do- W.unsafeWriteBit ib 0- let newContext = if- | c == W8.doubleQuote -> InJson- | c == W8.backSlash -> InEscape- | otherwise -> InString- buildFromByteString ib bp bs (i + 1) newContext- InEscape -> do- W.unsafeWriteBit ib 0- buildFromByteString ib bp bs (i + 1) InString- else do- ibv <- W.written ib- bpv <- W.written bp- return (SemiIndex context ibv bpv)-{-# INLINE buildFromByteString #-}
− src/HaskellWorks/Data/Json/Backend/Simple/Value.hs
@@ -1,43 +0,0 @@-module HaskellWorks.Data.Json.Backend.Simple.Value where--import Data.Maybe-import Data.Word-import HaskellWorks.Data.Json.Backend.Simple.Cursor-import HaskellWorks.Data.Positioning-import HaskellWorks.Data.RankSelect.Base.Select1-import HaskellWorks.Data.RankSelect.Poppy512--import qualified Data.ByteString as BS-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.BalancedParens as BP--data JsonValue- = JsonValues JsonValues- | JsonNull- | JsonNumber Double- | JsonString String- | JsonBoolean Bool- deriving (Eq, Show)--data JsonValues- = JsonArray [JsonValue]- | JsonObject [(String, JsonValue)]- deriving (Eq, Show)--snippetPos :: JsonCursor BS.ByteString Poppy512 (BP.SimpleBalancedParens (DVS.Vector Word64)) -> (Count, Count)-snippetPos k = (kpa, kpz)- where kpa = select1 kib kta + km- kpz = select1 kib ktz - km- kib = interests k- kbp = balancedParens k- kra = cursorRank k- krz = fromMaybe maxBound (BP.findClose kbp kra)- ksa = kra + 1- ksz = krz + 1- kta = ksa `div` 2- ktz = ksz `div` 2- km = ksa `mod` 2--snippet :: JsonCursor BS.ByteString Poppy512 (BP.SimpleBalancedParens (DVS.Vector Word64)) -> BS.ByteString-snippet k = let (a, z) = snippetPos k in BS.take (fromIntegral (z - a + 1)) (BS.drop (fromIntegral (a - 1)) kt)- where kt = cursorText k
− src/HaskellWorks/Data/Json/Backend/Standard/Cursor.hs
@@ -1,173 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}--module HaskellWorks.Data.Json.Backend.Standard.Cursor- ( JsonCursor(..)- , jsonCursorPos- ) where--import Control.Arrow-import Control.Monad-import Data.Char-import Data.String-import Data.Word8-import HaskellWorks.Data.Bits.BitWise-import HaskellWorks.Data.Drop-import HaskellWorks.Data.Json.DecodeError-import HaskellWorks.Data.Json.Internal.CharLike-import HaskellWorks.Data.Json.Internal.Index-import HaskellWorks.Data.Json.Internal.PartialIndex-import HaskellWorks.Data.Json.Internal.Slurp-import HaskellWorks.Data.Json.Internal.Word8-import HaskellWorks.Data.Json.LightJson-import HaskellWorks.Data.Json.PartialValue-import HaskellWorks.Data.Json.Type-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 JsonCursor t v w = JsonCursor- { cursorText :: !t- , interests :: !v- , balancedParens :: !w- , cursorRank :: !Count- }- deriving (Eq, Show)--instance (BP.BalancedParens u, Rank1 u, Rank0 u) => TreeCursor (JsonCursor t v u) where- firstChild :: JsonCursor t v u -> Maybe (JsonCursor t v u)- firstChild k = let mq = BP.firstChild (balancedParens k) (cursorRank k) in (\q -> k { cursorRank = q }) <$> mq-- nextSibling :: JsonCursor t v u -> Maybe (JsonCursor t v u)- nextSibling k = (\q -> k { cursorRank = q }) <$> BP.nextSibling (balancedParens k) (cursorRank k)-- parent :: JsonCursor t v u -> Maybe (JsonCursor t v u)- parent k = let mq = BP.parent (balancedParens k) (cursorRank k) in (\q -> k { cursorRank = q }) <$> mq-- depth :: JsonCursor t v u -> Maybe Count- depth k = BP.depth (balancedParens k) (cursorRank k)-- subtreeSize :: JsonCursor t v u -> Maybe Count- subtreeSize k = BP.subtreeSize (balancedParens k) (cursorRank k)--jsonCursorPos :: (Rank1 w, Select1 v) => JsonCursor s v w -> Position-jsonCursorPos k = toPosition (select1 ik (rank1 bpk (cursorRank k)) - 1)- where ik = interests k- bpk = balancedParens k--instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => LightJsonAt (JsonCursor BS.ByteString v w) where- lightJsonAt k = case uncons remainder of- Just (!c, _) | isLeadingDigit2 c -> LightJsonNumber (slurpNumber remainder)- Just (!c, _) | isQuotDbl c -> LightJsonString (slurpString remainder)- Just (!c, _) | isChar_t c -> LightJsonBool True- Just (!c, _) | isChar_f c -> LightJsonBool False- Just (!c, _) | isChar_n c -> LightJsonNull- Just (!c, _) | isBraceLeft c -> LightJsonObject (mapValuesFrom (firstChild k))- Just (!c, _) | isBracketLeft c -> LightJsonArray (arrayValuesFrom (firstChild k))- Just _ -> LightJsonError "Invalid Json Type"- Nothing -> LightJsonError "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 = L.unfoldr (fmap (id &&& nextSibling))- mapValuesFrom j = pairwise (arrayValuesFrom j) >>= asField- pairwise (a:b:rs) = (a, b) : pairwise rs- pairwise _ = []- asField (a, b) = case lightJsonAt a of- LightJsonString s -> [(s, b)]- _ -> []--instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => JsonTypeAt (JsonCursor String v w) where- jsonTypeAtPosition p k = case drop (toCount p) (cursorText k) of- c:_ | fromIntegral (ord c) == _bracketleft -> Just JsonTypeArray- c:_ | fromIntegral (ord c) == _f -> Just JsonTypeBool- c:_ | fromIntegral (ord c) == _t -> Just JsonTypeBool- c:_ | fromIntegral (ord c) == _n -> Just JsonTypeNull- c:_ | wIsJsonNumberDigit (fromIntegral (ord c)) -> Just JsonTypeNumber- c:_ | fromIntegral (ord c) == _braceleft -> Just JsonTypeObject- c:_ | fromIntegral (ord c) == _quotedbl -> Just JsonTypeString- _ -> Nothing-- jsonTypeAt k = jsonTypeAtPosition p k- where p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k)))- ik = interests k- bpk = balancedParens k--instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => JsonTypeAt (JsonCursor BS.ByteString v w) where- jsonTypeAtPosition p k = case BS.uncons (drop (toCount p) (cursorText k)) of- Just (c, _) | c == _bracketleft -> Just JsonTypeArray- Just (c, _) | c == _f -> Just JsonTypeBool- Just (c, _) | c == _t -> Just JsonTypeBool- Just (c, _) | c == _n -> Just JsonTypeNull- Just (c, _) | wIsJsonNumberDigit c -> Just JsonTypeNumber- Just (c, _) | c == _braceleft -> Just JsonTypeObject- Just (c, _) | c == _quotedbl -> Just JsonTypeString- _ -> Nothing-- jsonTypeAt k = jsonTypeAtPosition p k- where p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k)))- ik = interests k- bpk = balancedParens k--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)]- _ -> []--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)]- _ -> []--instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => JsonPartialValueAt (JsonCursor BS.ByteString v w) where- jsonPartialJsonValueAt = jsonPartialJsonValueAt . jsonPartialIndexAt
− src/HaskellWorks/Data/Json/Backend/Standard/Fast.hs
@@ -1,38 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}--module HaskellWorks.Data.Json.Backend.Standard.Fast- ( makeCursor- ) where--import Data.Word-import Foreign.ForeignPtr-import HaskellWorks.Data.FromForeignRegion-import HaskellWorks.Data.Json.Backend.Standard.Cursor-import HaskellWorks.Data.RankSelect.Poppy512--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.Internal as BSI-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.BalancedParens as BP-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.IbBp as J--class MakeCursor a where- makeCursor :: a -> JsonCursor BS.ByteString Poppy512 (BP.SimpleBalancedParens (DVS.Vector Word64))--instance MakeCursor BS.ByteString where- makeCursor bs = JsonCursor- { cursorText = bs- , interests = makePoppy512 ib- , balancedParens = BP.SimpleBalancedParens bp- , cursorRank = 1- }- where J.IbBp ib bp = J.toIbBp bs--instance MakeCursor String where- makeCursor = makeCursor . BSC.pack--instance MakeCursor ForeignRegion where- makeCursor (fptr, offset, size) = makeCursor (BSI.fromForeignPtr (castForeignPtr fptr) offset size)-
− src/HaskellWorks/Data/Json/Backend/Standard/Index.hs
@@ -1,20 +0,0 @@-module HaskellWorks.Data.Json.Backend.Standard.Index- ( indexJson- ) where--import Data.Word-import HaskellWorks.Data.BalancedParens.Simple-import HaskellWorks.Data.Json.Backend.Standard.Cursor--import qualified Data.ByteString as BS-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.ByteString as BS-import qualified HaskellWorks.Data.Json.Backend.Standard.Load.Cursor as L--indexJson :: String -> IO ()-indexJson filename = do- JsonCursor _ ib (SimpleBalancedParens bp) _ <- L.loadCursor filename- let wib = DVS.unsafeCast ib :: DVS.Vector Word8- let wbp = DVS.unsafeCast bp :: DVS.Vector Word8- BS.writeFile (filename ++ ".ib.idx") (BS.toByteString wib)- BS.writeFile (filename ++ ".bp.idx") (BS.toByteString wbp)
− src/HaskellWorks/Data/Json/Backend/Standard/Load/Cursor.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module HaskellWorks.Data.Json.Backend.Standard.Load.Cursor- ( loadCursor- , loadCursorWithIndex- , loadCursorWithPoppy512Index- , loadCursorWithCsPoppyIndex- , loadCursorWithPoppy512Index2- ) where--import Data.Word-import HaskellWorks.Data.BalancedParens.Simple-import HaskellWorks.Data.Json.Backend.Standard.Cursor-import HaskellWorks.Data.Json.Backend.Standard.Load.Raw-import HaskellWorks.Data.RankSelect.CsPoppy-import HaskellWorks.Data.RankSelect.Poppy512--import qualified Data.ByteString as BS-import qualified Data.ByteString.Internal as BSI-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.ByteString as BS-import qualified HaskellWorks.Data.Json.Backend.Standard.Slow as SLOW--loadCursor :: String -> IO (JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64)))-loadCursor path = do- bs <- BS.mmap path- let !cursor = SLOW.makeCursor bs- return cursor--loadCursorWithIndex :: String -> IO (JsonCursor BSI.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64)))-loadCursorWithIndex filename = do- (jsonBS, jsonIb, jsonBp) <- loadRawWithIndex filename- let cursor = JsonCursor jsonBS jsonIb (SimpleBalancedParens jsonBp) 1- return cursor--loadCursorWithPoppy512Index :: String -> IO (JsonCursor BSI.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64)))-loadCursorWithPoppy512Index filename = do- (jsonBS, jsonIb, jsonBp) <- loadRawWithIndex filename- let cursor = JsonCursor jsonBS (makePoppy512 jsonIb) (SimpleBalancedParens jsonBp) 1- return cursor--loadCursorWithCsPoppyIndex :: String -> IO (JsonCursor BSI.ByteString CsPoppy (SimpleBalancedParens (DVS.Vector Word64)))-loadCursorWithCsPoppyIndex filename = do- (jsonBS, jsonIb, jsonBp) <- loadRawWithIndex filename- let cursor = JsonCursor jsonBS (makeCsPoppy jsonIb) (SimpleBalancedParens jsonBp) 1- return cursor--loadCursorWithPoppy512Index2 :: String -> IO (JsonCursor BSI.ByteString Poppy512 (SimpleBalancedParens Poppy512))-loadCursorWithPoppy512Index2 filename = do- (jsonBS, jsonIb, jsonBp) <- loadRawWithIndex filename- let cursor = JsonCursor jsonBS (makePoppy512 jsonIb) (SimpleBalancedParens (makePoppy512 jsonBp)) 1- :: JsonCursor BSI.ByteString Poppy512 (SimpleBalancedParens Poppy512)- return cursor
− src/HaskellWorks/Data/Json/Backend/Standard/Load/Partial.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}--module HaskellWorks.Data.Json.Backend.Standard.Load.Partial- ( loadPartial- , loadPartialWithCsPoppyIndex- , loadPartialWithIndex- , loadPartialWithPoppy512Index- , loadPartialWithPoppy512Index2- ) where--import HaskellWorks.Data.BalancedParens.Simple-import HaskellWorks.Data.Bits.BitShown-import HaskellWorks.Data.Json.Backend.Standard.Cursor-import HaskellWorks.Data.Json.Backend.Standard.Load.Raw-import HaskellWorks.Data.Json.Internal.PartialIndex-import HaskellWorks.Data.Json.PartialValue-import HaskellWorks.Data.RankSelect.CsPoppy-import HaskellWorks.Data.RankSelect.Poppy512--import qualified Data.ByteString.Internal as BSI--loadPartialWithIndex :: String -> IO JsonPartialValue-loadPartialWithIndex filename = do- (jsonBS, jsonIb, jsonBp) <- loadRawWithIndex filename- let cursor = JsonCursor jsonBS (BitShown jsonIb) (SimpleBalancedParens jsonBp) 1- let !jsonResult = jsonPartialJsonValueAt (jsonPartialIndexAt cursor)- return jsonResult--loadPartialWithPoppy512Index :: String -> IO JsonPartialValue-loadPartialWithPoppy512Index filename = do- (jsonBS, jsonIb, jsonBp) <- loadRawWithIndex filename- let cursor = JsonCursor jsonBS (makePoppy512 jsonIb) (SimpleBalancedParens jsonBp) 1- let !jsonResult = jsonPartialJsonValueAt (jsonPartialIndexAt cursor)- return jsonResult--loadPartialWithCsPoppyIndex :: String -> IO JsonPartialValue-loadPartialWithCsPoppyIndex filename = do- (jsonBS, jsonIb, jsonBp) <- loadRawWithIndex filename- let cursor = JsonCursor jsonBS (makeCsPoppy jsonIb) (SimpleBalancedParens jsonBp) 1- let !jsonResult = jsonPartialJsonValueAt (jsonPartialIndexAt cursor)- return jsonResult--loadPartialWithPoppy512Index2 :: String -> IO JsonPartialValue-loadPartialWithPoppy512Index2 filename = do- (jsonBS, jsonIb, jsonBp) <- loadRawWithIndex filename- let cursor = JsonCursor jsonBS (makePoppy512 jsonIb) (SimpleBalancedParens (makePoppy512 jsonBp)) 1- :: JsonCursor BSI.ByteString Poppy512 (SimpleBalancedParens Poppy512)- let !jsonResult = jsonPartialJsonValueAt (jsonPartialIndexAt cursor)- return jsonResult--loadPartial :: String -> IO JsonPartialValue-loadPartial = loadPartialWithCsPoppyIndex
− src/HaskellWorks/Data/Json/Backend/Standard/Load/Raw.hs
@@ -1,20 +0,0 @@-module HaskellWorks.Data.Json.Backend.Standard.Load.Raw- ( loadRawWithIndex- ) where--import Data.Word-import HaskellWorks.Data.FromForeignRegion-import System.IO.MMap--import qualified Data.ByteString as BS-import qualified Data.Vector.Storable as DVS--loadRawWithIndex :: String -> IO (BS.ByteString, DVS.Vector Word64, DVS.Vector Word64)-loadRawWithIndex filename = do- jsonFr <- mmapFileForeignPtr filename ReadOnly Nothing- jsonIbFr <- mmapFileForeignPtr (filename ++ ".ib.idx") ReadOnly Nothing- jsonBpFr <- mmapFileForeignPtr (filename ++ ".bp.idx") ReadOnly Nothing- let jsonBS = fromForeignRegion jsonFr :: BS.ByteString- let jsonIb = fromForeignRegion jsonIbFr :: DVS.Vector Word64- let jsonBp = fromForeignRegion jsonBpFr :: DVS.Vector Word64- return (jsonBS, jsonIb, jsonBp)
− src/HaskellWorks/Data/Json/Backend/Standard/SemiIndex.hs
@@ -1,269 +0,0 @@-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--module HaskellWorks.Data.Json.Backend.Standard.SemiIndex- ( semiIndexBuilder- , SemiIndex(..)- , PreSiChunk(..)- , SiChunk(..)- , buildSemiIndex- , State(..)- , buildFromByteString2- , buildFromByteString3- , toIbBpBuilders- ) where--import Control.Monad.ST-import Data.Bits.Pdep-import Data.Bits.Pext-import Data.Word-import Foreign.Storable (Storable (..))-import HaskellWorks.Data.Bits.BitWise-import HaskellWorks.Data.Bits.PopCount.PopCount1-import HaskellWorks.Data.Json.Internal.Backend.Standard.StateMachine (IntState (..), State (..))-import HaskellWorks.Data.Vector.AsVector64--import qualified Data.ByteString as BS-import qualified Data.ByteString.Builder as B-import qualified Data.ByteString.Lazy as LBS-import qualified Data.ByteString.Unsafe as BSU-import qualified Data.Vector.Storable as DVS-import qualified Data.Vector.Storable.Mutable as DVSM-import qualified HaskellWorks.Data.Bits.Writer.Storable as W-import qualified HaskellWorks.Data.ByteString as BS-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.Blank as J-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.BlankedJson as J-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.MakeIndex as J-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.StateMachine as SM-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.ToBalancedParens64 as J-import qualified HaskellWorks.Data.Json.Internal.Word8 as W8--{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}-{-# ANN module ("HLint: ignore Redundant do" :: String) #-}--data PreSiChunk v = PreSiChunk- { preSiChunkIb :: !v -- interest bits- , preSiChunkBpOp :: !v -- balanced parens interest bits- , preSiChunkBpCl :: !v -- balanced parens open close- } deriving (Functor, Traversable, Foldable)--data SiChunk v = SiChunk- { siChunkIb :: !v -- interest bits- , siChunkBp :: !v -- balanced parens open close- } deriving (Functor, Traversable, Foldable)--data SemiIndex v = SemiIndex- { semiIndexIb :: !v- , semiIndexBp :: !v- } deriving (Functor, Traversable, Foldable)--semiIndexBuilder :: LBS.ByteString -> SemiIndex B.Builder-semiIndexBuilder lbs = SemiIndex (B.lazyByteString ibs) (B.byteString (BS.toByteString bps))- where blankedJson = J.blankJson (LBS.toChunks lbs)- ibs = LBS.fromChunks (J.blankedJsonToInterestBits blankedJson)- bps = J.toBalancedParens64 (J.BlankedJson blankedJson)-{-# INLINE semiIndexBuilder #-}--buildSemiIndex :: BS.ByteString -> SemiIndex (DVS.Vector Word64)-buildSemiIndex bs = DVS.createT $ do- let len = (BS.length bs + 7) `div` 8- mib <- W.newWriter len- mbp <- W.newWriter (len * 2)- buildFromByteString mib mbp bs 0 InJson-{-# INLINE buildSemiIndex #-}--buildFromByteString :: W.Writer s -> W.Writer s -> BS.ByteString -> Int -> State -> ST s (SemiIndex (DVS.MVector s Word64))-buildFromByteString ib bp bs i = go- where go state = if i < BS.length bs- then do- let c = BSU.unsafeIndex bs i- case state of- InJson -> if- | c == W8.openBracket || c == W8.openBrace -> do- W.unsafeWriteBit ib 1- W.unsafeWriteBit bp 1- buildFromByteString ib bp bs (i + 1) InJson- | c == W8.closeBracket || c == W8.closeBrace -> do- W.unsafeWriteBit bp 0- W.unsafeWriteBit ib 0- buildFromByteString ib bp bs (i + 1) InJson- | c == W8.comma || c == W8.colon -> do- W.unsafeWriteBit ib 0- buildFromByteString ib bp bs (i + 1) InJson- | W8.isAlphabetic c || W8.isDigit c || W8.isPeriod c || W8.isMinus c || W8.isPlus c -> do- W.unsafeWriteBit ib 1- W.unsafeWriteBit bp 1- W.unsafeWriteBit bp 0- buildFromByteString ib bp bs (i + 1) InValue- | c == W8.doubleQuote -> do- W.unsafeWriteBit ib 1- W.unsafeWriteBit bp 1- W.unsafeWriteBit bp 0- buildFromByteString ib bp bs (i + 1) InString- | otherwise -> do- W.unsafeWriteBit ib 0- buildFromByteString ib bp bs (i + 1) InJson- InString -> do- W.unsafeWriteBit ib 0- let newContext = if- | c == W8.doubleQuote -> InJson- | c == W8.backSlash -> InEscape- | otherwise -> InString- buildFromByteString ib bp bs (i + 1) newContext- InEscape -> do- W.unsafeWriteBit ib 0- buildFromByteString ib bp bs (i + 1) InString- InValue -> if- | W8.isAlphabetic c || W8.isDigit c || W8.isPeriod c || W8.isMinus c || W8.isPlus c -> do- W.unsafeWriteBit ib 0- buildFromByteString ib bp bs (i + 1) InValue- | otherwise -> go InJson- else do- ibv <- W.written ib- bpv <- W.written bp- return (SemiIndex ibv bpv)-{-# INLINE buildFromByteString #-}--constructSI :: forall a s. Storable a => Int -> (Int -> s -> (s, a)) -> s -> (s, DVS.Vector a)-constructSI n f state = DVS.createT $ do- mv <- DVSM.unsafeNew n- state' <- go 0 state mv- return (state', mv)- where go :: Int -> s -> DVSM.MVector t a -> ST t s- go i s mv = if i < DVSM.length mv- then do- let (s', a) = f i s- DVSM.unsafeWrite mv i a- go (i + 1) s' mv- else return s-{-# INLINE constructSI #-}--buildFromByteString2 :: [BS.ByteString] -> [DVS.Vector Word64]-buildFromByteString2 = go (IntState (fromEnum InJson))- where go :: IntState -> [BS.ByteString] -> [DVS.Vector Word64]- go s (bs:bss) = v:go s' bss- where (s', v) = constructSI (BS.length bs `div` 16) f s -- TODO adjust length- f :: Int -> IntState -> (IntState, Word64)- f i s'' = let j = i * 16 in transition16 s''- (BSU.unsafeIndex bs j )- (BSU.unsafeIndex bs (j + 1))- (BSU.unsafeIndex bs (j + 2))- (BSU.unsafeIndex bs (j + 3))- (BSU.unsafeIndex bs (j + 4))- (BSU.unsafeIndex bs (j + 5))- (BSU.unsafeIndex bs (j + 6))- (BSU.unsafeIndex bs (j + 7))- (BSU.unsafeIndex bs (j + 8))- (BSU.unsafeIndex bs (j + 9))- (BSU.unsafeIndex bs (j + 10))- (BSU.unsafeIndex bs (j + 11))- (BSU.unsafeIndex bs (j + 12))- (BSU.unsafeIndex bs (j + 13))- (BSU.unsafeIndex bs (j + 14))- (BSU.unsafeIndex bs (j + 15))- go _ [] = []-{-# INLINE buildFromByteString2 #-}--transition16 :: IntState- -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8- -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8- -> (IntState, Word64)-transition16 s a b c d e f g h i j k l m n o p = (sp, w)- where (sa, wa) = transition1 s a- (sb, wb) = transition1 sa b- (sc, wc) = transition1 sb c- (sd, wd) = transition1 sc d- (se, we) = transition1 sd e- (sf, wf) = transition1 se f- (sg, wg) = transition1 sf g- (sh, wh) = transition1 sg h- (si, wi) = transition1 sh i- (sj, wj) = transition1 si j- (sk, wk) = transition1 sj k- (sl, wl) = transition1 sk l- (sm, wm) = transition1 sl m- (sn, wn) = transition1 sm n- (so, wo) = transition1 sn o- (sp, wp) = transition1 so p- w = (fromIntegral wa ) .|.- (fromIntegral wb .<. 4) .|.- (fromIntegral wc .<. 8) .|.- (fromIntegral wd .<. 12) .|.- (fromIntegral we .<. 16) .|.- (fromIntegral wf .<. 20) .|.- (fromIntegral wg .<. 24) .|.- (fromIntegral wh .<. 28) .|.- (fromIntegral wi .<. 32) .|.- (fromIntegral wj .<. 36) .|.- (fromIntegral wk .<. 40) .|.- (fromIntegral wl .<. 44) .|.- (fromIntegral wm .<. 48) .|.- (fromIntegral wn .<. 52) .|.- (fromIntegral wo .<. 56) .|.- (fromIntegral wp .<. 60)-{-# INLINE transition16 #-}--transition1 :: IntState -> Word8 -> (IntState, Word64)-transition1 s a = (s', w)- where s' = SM.lookupTransitionTable s (fromIntegral a)- w = fromIntegral $ SM.lookupPhiTable s (fromIntegral a)-{-# INLINE transition1 #-}--buildFromByteString3 :: [BS.ByteString] -> [PreSiChunk (DVS.Vector Word64)]-buildFromByteString3 bss = makePreSiChunk <$> buildFromByteString2 bss- where makePreSiChunk :: DVS.Vector Word64 -> PreSiChunk (DVS.Vector Word64)- makePreSiChunk v = PreSiChunk (makeIb v) (makeBpOp v) (makeBpCl v)- makeIb :: DVS.Vector Word64 -> DVS.Vector Word64- makeIb v = asVector64 $ BS.toByteString $ DVS.constructN (DVS.length v) go- where go :: DVS.Vector Word16 -> Word16- go u = let ui = DVS.length u in fromIntegral (pext (DVS.unsafeIndex v ui) 0x4444444444444444)- makeBpOp :: DVS.Vector Word64 -> DVS.Vector Word64- makeBpOp v = asVector64 $ BS.toByteString $ DVS.constructN (DVS.length v) go- where go :: DVS.Vector Word16 -> Word16- go u = let ui = DVS.length u in fromIntegral (pext (DVS.unsafeIndex v ui) 0x2222222222222222)- makeBpCl v = asVector64 $ BS.toByteString $ DVS.constructN (DVS.length v) go- where go :: DVS.Vector Word16 -> Word16- go u = let ui = DVS.length u in fromIntegral (pext (DVS.unsafeIndex v ui) 0x1111111111111111)--toIbBpBuilders :: [PreSiChunk (DVS.Vector Word64)] -> [SiChunk (DVS.Vector Word64)]-toIbBpBuilders = go 0 0- where go :: Word64 -> Word64 -> [PreSiChunk (DVS.Vector Word64)] -> [SiChunk (DVS.Vector Word64)]- go b n (PreSiChunk ib bpOp bpCl:cs) = SiChunk ib bp: go b' n' cs- where ((b', n'), bp) = mkBp b n (DVS.unsafeCast bpOp) (DVS.unsafeCast bpCl)- go b _ [] = [SiChunk DVS.empty (DVS.singleton b)]- mkBp :: Word64 -> Word64 -> DVS.Vector Word32 -> DVS.Vector Word32 -> ((Word64, Word64), DVS.Vector Word64)- mkBp b n bpOp bpCl = DVS.createT $ do- mv <- DVSM.unsafeNew (DVS.length bpOp)- mkBpGo b n bpOp bpCl mv 0 0- mkBpGo :: Word64 -> Word64 -> DVS.Vector Word32 -> DVS.Vector Word32 -> DVS.MVector s Word64 -> Int -> Int -> ST s ((Word64, Word64), DVS.MVector s Word64)- mkBpGo b n bpOp bpCl mv vi mvi = if vi < DVS.length bpOp- then do- let op = DVS.unsafeIndex bpOp vi- let cl = DVS.unsafeIndex bpCl vi- let (slo, mlo) = compress op cl -- slo: source lo, mlo: mask lo- let wb = pext slo mlo- let wn = popCount1 mlo- let tb = (wb .<. n) .|. b- let tn = n + wn- if tn < 64- then do- mkBpGo tb tn bpOp bpCl mv (vi + 1) mvi- else do- DVSM.unsafeWrite mv mvi tb- let ub = wb .>. (64 - n)- let un = tn - 64- mkBpGo ub un bpOp bpCl mv (vi + 1) (mvi + 1)- else return ((b, n), DVSM.take mvi mv)- compress :: Word32 -> Word32 -> (Word64, Word64)- compress op cl = (sw, mw)- where iop = pdep (fromIntegral op :: Word64) 0x5555555555555555 -- interleaved open- icl = pdep (fromIntegral cl :: Word64) 0xaaaaaaaaaaaaaaaa -- interleaved close- ioc = iop .|. icl -- interleaved open/close- sw = pext iop ioc- pc = popCount1 ioc- mw = (1 .<. pc) - 1
− src/HaskellWorks/Data/Json/Backend/Standard/Slow.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}--module HaskellWorks.Data.Json.Backend.Standard.Slow- ( makeCursor- ) where--import Data.Word-import Foreign.ForeignPtr-import HaskellWorks.Data.FromForeignRegion-import HaskellWorks.Data.Json.Backend.Standard.Cursor--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.Internal as BSI-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.BalancedParens as BP-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.IbBp as J--class MakeCursor a where- makeCursor :: a -> JsonCursor BS.ByteString (DVS.Vector Word64) (BP.SimpleBalancedParens (DVS.Vector Word64))--instance MakeCursor BS.ByteString where- makeCursor bs = JsonCursor- { cursorText = bs- , interests = ib- , balancedParens = BP.SimpleBalancedParens bp- , cursorRank = 1- }- where J.IbBp ib bp = J.toIbBp bs--instance MakeCursor String where- makeCursor = makeCursor . BSC.pack--instance MakeCursor ForeignRegion where- makeCursor (fptr, offset, size) = makeCursor (BSI.fromForeignPtr (castForeignPtr fptr) offset size)
src/HaskellWorks/Data/Json/FromValue.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} module HaskellWorks.Data.Json.FromValue where +import Data.Text (Text) import HaskellWorks.Data.Json.DecodeError import HaskellWorks.Data.Json.Value +import qualified Data.Text as T+ class FromJsonValue a where fromJsonValue :: JsonValue -> Either DecodeError a @@ -14,28 +16,33 @@ instance FromJsonValue String where fromJsonValue v = case v of- JsonString r -> Right r- _ -> Left (DecodeError "Not a string")+ JsonString r -> Right (T.unpack r)+ _ -> Left (DecodeError "Not a string") +instance FromJsonValue Text where+ fromJsonValue v = case v of+ JsonString r -> Right r+ _ -> Left (DecodeError "Not a string")+ instance FromJsonValue Int where fromJsonValue v = case v of- JsonNumber r -> Right (floor r)- _ -> Left (DecodeError "Not an integer")+ JsonNumber r -> Right (floor r)+ _ -> Left (DecodeError "Not an integer") instance FromJsonValue Double where fromJsonValue v = case v of- JsonNumber r -> Right r- _ -> Left (DecodeError "Not a double")+ JsonNumber r -> Right r+ _ -> Left (DecodeError "Not a double") instance FromJsonValue Bool where fromJsonValue v = case v of- JsonBool r -> Right r- _ -> Left (DecodeError "Not a boolean")+ JsonBool r -> Right r+ _ -> Left (DecodeError "Not a boolean") instance FromJsonValue a => FromJsonValue [a] where fromJsonValue v = case v of- JsonArray xs -> mapM fromJsonValue xs- _ -> Left (DecodeError "Not an array")+ JsonArray xs -> mapM fromJsonValue xs+ _ -> Left (DecodeError "Not an array") instance (FromJsonValue a, FromJsonValue b) => FromJsonValue (a, b) where fromJsonValue v = case v of
− src/HaskellWorks/Data/Json/Internal/Backend/Simple/IbBp.hs
@@ -1,10 +0,0 @@-module HaskellWorks.Data.Json.Internal.Backend.Simple.IbBp where--import Data.Word--import qualified Data.Vector.Storable as DVS--data IbBp = IbBp- { ib :: DVS.Vector Word64- , bp :: DVS.Vector Word64- }
− src/HaskellWorks/Data/Json/Internal/Backend/Simple/ToIbBp.hs
@@ -1,12 +0,0 @@-module HaskellWorks.Data.Json.Internal.Backend.Simple.ToIbBp where--import qualified Data.ByteString as BS-import qualified HaskellWorks.Data.Json.Backend.Simple.SemiIndex as J-import qualified HaskellWorks.Data.Json.Internal.Backend.Simple.IbBp as Z--class ToIbBp a where- toIbBp :: a -> Z.IbBp--instance ToIbBp BS.ByteString where- toIbBp bs = Z.IbBp ib bp- where J.SemiIndex _ ib bp = J.buildSemiIndex bs
− src/HaskellWorks/Data/Json/Internal/Backend/Standard/Blank.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module HaskellWorks.Data.Json.Internal.Backend.Standard.Blank- ( blankJson- ) where--import Data.ByteString as BS-import Data.Word-import Data.Word8-import HaskellWorks.Data.Json.Internal.Word8-import Prelude as P--data BlankState- = Escaped- | InJson- | InString- | InNumber- | InIdent--blankJson :: [BS.ByteString] -> [BS.ByteString]-blankJson = blankJson' InJson--blankJson' :: BlankState -> [BS.ByteString] -> [BS.ByteString]-blankJson' lastState as = case as of- (bs:bss) ->- let (!cs, Just (!nextState, _)) = unfoldrN (BS.length bs) blankByteString (lastState, bs) in- cs:blankJson' nextState bss- [] -> []- where- blankByteString :: (BlankState, ByteString) -> Maybe (Word8, (BlankState, ByteString))- blankByteString (InJson, bs) = case BS.uncons bs of- Just (!c, !cs) | isLeadingDigit c -> Just (_1 , (InNumber , cs))- Just (!c, !cs) | c == _quotedbl -> Just (_parenleft , (InString , cs))- Just (!c, !cs) | isAlphabetic c -> Just (c , (InIdent , cs))- Just (!c, !cs) -> Just (c , (InJson , cs))- Nothing -> Nothing- blankByteString (InString, bs) = case BS.uncons bs of- Just (!c, !cs) | c == _backslash -> Just (_space , (Escaped , cs))- Just (!c, !cs) | c == _quotedbl -> Just (_parenright , (InJson , cs))- Just (_ , !cs) -> Just (_space , (InString , cs))- Nothing -> Nothing- blankByteString (Escaped, bs) = case BS.uncons bs of- Just (_, !cs) -> Just (_space, (InString, cs))- Nothing -> Nothing- blankByteString (InNumber, bs) = case BS.uncons bs of- Just (!c, !cs) | isTrailingDigit c -> Just (_0 , (InNumber , cs))- Just (!c, !cs) | c == _quotedbl -> Just (_parenleft , (InString , cs))- Just (!c, !cs) | isAlphabetic c -> Just (c , (InIdent , cs))- Just (!c, !cs) -> Just (c , (InJson , cs))- Nothing -> Nothing- blankByteString (InIdent, bs) = case BS.uncons bs of- Just (!c, !cs) | isAlphabetic c -> Just (_underscore , (InIdent , cs))- Just (!c, !cs) | isLeadingDigit c -> Just (_1 , (InNumber , cs))- Just (!c, !cs) | c == _quotedbl -> Just (_parenleft , (InString , cs))- Just (!c, !cs) -> Just (c , (InJson , cs))- Nothing -> Nothing
− src/HaskellWorks/Data/Json/Internal/Backend/Standard/BlankedJson.hs
@@ -1,24 +0,0 @@--module HaskellWorks.Data.Json.Internal.Backend.Standard.BlankedJson- ( BlankedJson(..)- , ToBlankedJson(..)- , toBlankedJsonTyped- ) where--import HaskellWorks.Data.ByteString-import HaskellWorks.Data.Json.Internal.Backend.Standard.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
− src/HaskellWorks/Data/Json/Internal/Backend/Standard/Cursor/Token.hs
@@ -1,24 +0,0 @@--module HaskellWorks.Data.Json.Internal.Backend.Standard.Cursor.Token- ( jsonTokenAt- ) where--import Data.ByteString.Internal as BSI-import HaskellWorks.Data.Bits.BitWise-import HaskellWorks.Data.Drop-import HaskellWorks.Data.Json.Backend.Standard.Cursor-import HaskellWorks.Data.Json.Internal.Backend.Standard.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
− src/HaskellWorks/Data/Json/Internal/Backend/Standard/IbBp.hs
@@ -1,24 +0,0 @@-module HaskellWorks.Data.Json.Internal.Backend.Standard.IbBp where--import Data.Word--import qualified Data.ByteString as BS-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.BlankedJson as J-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.ToBalancedParens64 as J-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.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
− src/HaskellWorks/Data/Json/Internal/Backend/Standard/MakeIndex.hs
@@ -1,134 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}--module HaskellWorks.Data.Json.Internal.Backend.Standard.MakeIndex- ( blankedJsonToInterestBits- , byteStringToBits- , blankedJsonToBalancedParens- , compressWordAsBit- , interestingWord8s- ) where--import Control.Monad-import Data.Array.Unboxed ((!))-import Data.ByteString (ByteString)-import Data.Int-import Data.Word-import Data.Word8-import HaskellWorks.Data.Bits.BitWise-import Prelude as P--import qualified Data.Array.Unboxed as A-import qualified Data.Bits as BITS-import qualified Data.ByteString as BS--interestingWord8s :: A.UArray Word8 Word8-interestingWord8s = A.array (0, 255) [- (w, if w == _bracketleft || w == _braceleft || w == _parenleft || w == _t || w == _f || w == _n || w == _1- then 1- else 0)- | w <- [0 .. 255]]--blankedJsonToInterestBits :: [BS.ByteString] -> [BS.ByteString]-blankedJsonToInterestBits = blankedJsonToInterestBits' ""--padRight :: Word8 -> Int -> BS.ByteString -> BS.ByteString-padRight w n bs = if BS.length bs >= n then bs else fst (BS.unfoldrN n gen bs)- where gen :: ByteString -> Maybe (Word8, ByteString)- gen cs = case BS.uncons cs of- Just (c, ds) -> Just (c, ds)- Nothing -> Just (w, BS.empty)--blankedJsonToInterestBits' :: BS.ByteString -> [BS.ByteString] -> [BS.ByteString]-blankedJsonToInterestBits' rs as = case as of- (bs:bss) ->- let cs = if BS.length rs /= 0 then BS.concat [rs, bs] else bs in- let lencs = BS.length cs in- let q = lencs + 7 `quot` 8 in- let (ds, es) = BS.splitAt (q * 8) cs in- let (fs, _) = BS.unfoldrN q gen ds in- fs:blankedJsonToInterestBits' es bss- [] -> []- where gen :: ByteString -> Maybe (Word8, ByteString)- gen ds = if BS.length ds == 0- then Nothing- else Just ( BS.foldr (\b m -> (interestingWord8s ! b) .|. (m .<. 1)) 0 (padRight 0 8 (BS.take 8 ds))- , BS.drop 8 ds- )--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]- abLen = BS.length abBS- cLen = (abLen `div` 8) * 8--compressWordAsBit :: [BS.ByteString] -> [BS.ByteString]-compressWordAsBit = compressWordAsBit' BS.empty--compressWordAsBit' :: BS.ByteString -> [BS.ByteString] -> [BS.ByteString]-compressWordAsBit' aBS as = case as of- (bBS:bBSs) ->- let (cBS, dBS) = repartitionMod8 aBS bBS in- let (cs, _) = BS.unfoldrN (BS.length cBS + 7 `div` 8) gen cBS in- cs:compressWordAsBit' dBS bBSs- [] -> do- let (cs, _) = BS.unfoldrN (BS.length aBS + 7 `div` 8) gen aBS- [cs]- where gen :: ByteString -> Maybe (Word8, ByteString)- gen xs = if BS.length xs == 0- then Nothing- else Just ( BS.foldr (\b m -> ((b .&. 1) .|. (m .<. 1))) 0 (padRight 0 8 (BS.take 8 xs))- , BS.drop 8 xs- )--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:blankedJsonToBalancedParens bss- [] -> []- where gen :: (Maybe Bool, ByteString) -> Maybe (Word8, (Maybe Bool, ByteString))- gen (Just True , bs) = Just (0xFF, (Nothing, bs))- gen (Just False , bs) = Just (0x00, (Nothing, bs))- gen (Nothing , bs) = case BS.uncons bs of- Just (c, cs) -> case balancedParensOf c of- MiniN -> gen (Nothing , cs)- MiniT -> Just (0xFF, (Nothing , cs))- MiniF -> Just (0x00, (Nothing , cs))- MiniTF -> Just (0xFF, (Just False , cs))- Nothing -> Nothing--data MiniBP = MiniN | MiniT | MiniF | MiniTF--balancedParensOf :: Word8 -> MiniBP-balancedParensOf c = case c of- d | d == _braceleft -> MiniT- d | d == _braceright -> MiniF- d | d == _bracketleft -> MiniT- d | d == _bracketright -> MiniF- d | d == _parenleft -> MiniT- d | d == _parenright -> MiniF- d | d == _t -> MiniTF- d | d == _f -> MiniTF- d | d == _1 -> MiniTF- d | d == _n -> MiniTF- _ -> MiniN--yieldBitsOfWord8 :: Word8 -> [Bool] -> [Bool]-yieldBitsOfWord8 w =- (((w .&. BITS.bit 0) /= 0):) .- (((w .&. BITS.bit 1) /= 0):) .- (((w .&. BITS.bit 2) /= 0):) .- (((w .&. BITS.bit 3) /= 0):) .- (((w .&. BITS.bit 4) /= 0):) .- (((w .&. BITS.bit 5) /= 0):) .- (((w .&. BITS.bit 6) /= 0):) .- (((w .&. BITS.bit 7) /= 0):)--yieldBitsofWord8s :: [Word8] -> [Bool] -> [Bool]-yieldBitsofWord8s = P.foldr ((>>) . yieldBitsOfWord8) id--byteStringToBits :: [BS.ByteString] -> [Bool] -> [Bool]-byteStringToBits as = case as of- (bs:bss) -> yieldBitsofWord8s (BS.unpack bs) . byteStringToBits bss- [] -> id
− src/HaskellWorks/Data/Json/Internal/Backend/Standard/StateMachine.hs
@@ -1,109 +0,0 @@-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}--module HaskellWorks.Data.Json.Internal.Backend.Standard.StateMachine- ( lookupPhiTable- , lookupTransitionTable- , phiTable- , phiTableSimd- , transitionTable- , transitionTableSimd- , IntState(..)- , State(..)- ) where--import Data.Word-import HaskellWorks.Data.Bits.BitWise--import qualified Data.Vector as DV-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.Json.Internal.Word8 as W8--{-# ANN module ("HLint: ignore Redundant guard" :: String) #-}--newtype IntState = IntState Int deriving (Eq, Ord, Show, Num)--data State = InJson | InString | InEscape | InValue deriving (Eq, Enum, Bounded, Show)--phiTable :: DV.Vector (DVS.Vector Word8)-phiTable = DV.constructN 5 gos- where gos :: DV.Vector (DVS.Vector Word8) -> DVS.Vector Word8- gos v = DVS.constructN 256 go- where vi = DV.length v- go :: DVS.Vector Word8 -> Word8- go u = fromIntegral (snd (stateMachine (fromIntegral ui) (toEnum vi)))- where ui = DVS.length u-{-# NOINLINE phiTable #-}--phiTable2 :: DVS.Vector Word8-phiTable2 = DVS.constructN (4 * fromIntegral iLen) go- where iLen = 256 :: Int- go :: DVS.Vector Word8 -> Word8- go u = fromIntegral (snd (stateMachine (fromIntegral ui) (toEnum (fromIntegral uj))))- where (uj, ui) = fromIntegral (DVS.length u) `divMod` iLen-{-# NOINLINE phiTable2 #-}--lookupPhiTable :: IntState -> Word8 -> Word8-lookupPhiTable (IntState s) w = DVS.unsafeIndex phiTable2 (s * 256 + fromIntegral w)-{-# INLINE lookupPhiTable #-}--phiTableSimd :: DVS.Vector Word32-phiTableSimd = DVS.constructN 256 go- where go :: DVS.Vector Word32 -> Word32- go v = (snd (stateMachine vi InJson ) .<. 0) .|.- (snd (stateMachine vi InString) .<. 8) .|.- (snd (stateMachine vi InEscape) .<. 16) .|.- (snd (stateMachine vi InValue ) .<. 24)- where vi = fromIntegral (DVS.length v)-{-# NOINLINE phiTableSimd #-}--transitionTable :: DV.Vector (DVS.Vector Word8)-transitionTable = DV.constructN 5 gos- where gos :: DV.Vector (DVS.Vector Word8) -> DVS.Vector Word8- gos v = DVS.constructN 256 go- where vi = DV.length v- go :: DVS.Vector Word8 -> Word8- go u = fromIntegral (fromEnum (fst (stateMachine ui (toEnum vi))))- where ui = fromIntegral (DVS.length u)-{-# NOINLINE transitionTable #-}--transitionTable2 :: DVS.Vector Word8-transitionTable2 = DVS.constructN (4 * fromIntegral iLen) go- where iLen = 256 :: Int- go :: DVS.Vector Word8 -> Word8- go u = fromIntegral (fromEnum (fst (stateMachine (fromIntegral ui) (toEnum (fromIntegral uj)))))- where (uj, ui) = fromIntegral (DVS.length u) `divMod` iLen-{-# NOINLINE transitionTable2 #-}--lookupTransitionTable :: IntState -> Word8 -> IntState-lookupTransitionTable (IntState s) w = fromIntegral (DVS.unsafeIndex transitionTable2 (s * 256 + fromIntegral w))-{-# INLINE lookupTransitionTable #-}--transitionTableSimd :: DVS.Vector Word64-transitionTableSimd = DVS.constructN 256 go- where go :: DVS.Vector Word64 -> Word64- go v = fromIntegral (fromEnum (fst (stateMachine vi InJson ))) .|.- fromIntegral (fromEnum (fst (stateMachine vi InString))) .|.- fromIntegral (fromEnum (fst (stateMachine vi InEscape))) .|.- fromIntegral (fromEnum (fst (stateMachine vi InValue )))- where vi = fromIntegral (DVS.length v)-{-# NOINLINE transitionTableSimd #-}--stateMachine :: Word8 -> State -> (State, Word32)-stateMachine c InJson | W8.isOpen c = (InJson , 0b110)-stateMachine c InJson | W8.isClose c = (InJson , 0b001)-stateMachine c InJson | W8.isDelim c = (InJson , 0b000)-stateMachine c InJson | W8.isValueChar c = (InValue , 0b111)-stateMachine c InJson | W8.isDoubleQuote c = (InString, 0b111)-stateMachine _ InJson | otherwise = (InJson , 0b000)-stateMachine c InString | W8.isDoubleQuote c = (InJson , 0b000)-stateMachine c InString | W8.isBackSlash c = (InEscape, 0b000)-stateMachine _ InString | otherwise = (InString, 0b000)-stateMachine _ InEscape | otherwise = (InString, 0b000)-stateMachine c InValue | W8.isOpen c = (InJson , 0b110)-stateMachine c InValue | W8.isClose c = (InJson , 0b001)-stateMachine c InValue | W8.isDelim c = (InJson , 0b000)-stateMachine c InValue | W8.isValueChar c = (InValue , 0b000)-stateMachine _ InValue | otherwise = (InJson , 0b000)-{-# INLINE stateMachine #-}
− src/HaskellWorks/Data/Json/Internal/Backend/Standard/ToBalancedParens64.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module HaskellWorks.Data.Json.Internal.Backend.Standard.ToBalancedParens64- ( ToBalancedParens64(..)- ) where--import Control.Applicative-import Data.Word-import HaskellWorks.Data.Json.Internal.Backend.Standard.MakeIndex--import qualified Data.ByteString.Lazy as LBS-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.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)
− src/HaskellWorks/Data/Json/Internal/Backend/Standard/ToInterestBits64.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module HaskellWorks.Data.Json.Internal.Backend.Standard.ToInterestBits64- ( ToInterestBits64(..)- ) where--import Control.Applicative-import Data.ByteString.Internal-import Data.Word-import HaskellWorks.Data.Json.Internal.Backend.Standard.MakeIndex--import qualified Data.ByteString as BS-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.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)
− src/HaskellWorks/Data/Json/Internal/Backend/Standard/Token/Tokenize.hs
@@ -1,165 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-}--module HaskellWorks.Data.Json.Internal.Backend.Standard.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)
src/HaskellWorks/Data/Json/Internal/CharLike.hs view
@@ -2,7 +2,7 @@ import Data.Word import Data.Word8-import HaskellWorks.Data.Json.Internal.Word8+import HaskellWorks.Data.Json.Standard.Cursor.Internal.Word8 class JsonCharLike c where isLeadingDigit2 :: c -> Bool
src/HaskellWorks/Data/Json/Internal/Doc.hs view
@@ -1,11 +1,27 @@ module HaskellWorks.Data.Json.Internal.Doc- ( hEncloseSep+ ( hEncloseSep,+ text,+ red,+ dullgreen,+ cyan, ) where -import Text.PrettyPrint.ANSI.Leijen+import Prettyprinter -hEncloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc+hEncloseSep :: Doc a -> Doc a -> Doc a -> [Doc a] -> Doc a hEncloseSep l r s ds = case ds of [] -> l <> r [d] -> l <> d <> r _ -> hcat (zipWith (<>) (l : repeat s) ds) <> r++text :: String -> Doc a+text = pretty++red :: Doc a -> Doc a+red = id++dullgreen :: Doc a -> Doc a+dullgreen = id++cyan :: Doc a -> Doc a+cyan = id
src/HaskellWorks/Data/Json/Internal/Index.hs view
@@ -1,12 +1,27 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} 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.DecodeError-import Prelude hiding (drop)+import HaskellWorks.Data.Json.Internal.CharLike+import HaskellWorks.Data.Json.Standard.Cursor.Generic+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.ByteString as BS+import qualified Data.List as L+import qualified HaskellWorks.Data.BalancedParens as BP data JsonIndex = JsonIndexString BS.ByteString@@ -19,3 +34,26 @@ class JsonIndexAt a where jsonIndexAt :: a -> Either DecodeError JsonIndex++instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => JsonIndexAt (GenericCursor 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)]+ _ -> []
src/HaskellWorks/Data/Json/Internal/PartialIndex.hs view
@@ -1,7 +1,33 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ module HaskellWorks.Data.Json.Internal.PartialIndex where -import qualified Data.ByteString as BS+import Control.Arrow+import Control.Monad+import Data.String+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Drop+import HaskellWorks.Data.Json.Internal.CharLike+import HaskellWorks.Data.Json.Standard.Cursor.Generic+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@@ -14,3 +40,28 @@ class JsonPartialIndexAt a where jsonPartialIndexAt :: a -> JsonPartialIndex++instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => JsonPartialIndexAt (GenericCursor 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 (GenericCursor 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)]+ _ -> []+
src/HaskellWorks/Data/Json/Internal/Slurp.hs view
@@ -1,16 +1,21 @@ {-# LANGUAGE BangPatterns #-} -module HaskellWorks.Data.Json.Internal.Slurp where+module HaskellWorks.Data.Json.Internal.Slurp+ ( JsonState(..)+ , slurpText+ , slurpNumber+ ) where -import Data.String+import Data.Text import Data.Word import Data.Word8-import HaskellWorks.Data.Json.Internal.Word8-import Prelude hiding (drop)+import HaskellWorks.Data.Json.Standard.Cursor.Internal.Word8+import Prelude hiding (drop) -import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-import qualified Data.List as L+import qualified Data.Aeson.Parser.Internal as AP+import qualified Data.Attoparsec.ByteString as PBS+import qualified Data.ByteString as BS+import qualified Data.Text as T data JsonState = Escaped@@ -19,23 +24,29 @@ | InNumber | InIdent -slurpString :: BS.ByteString -> String-slurpString bs = L.unfoldr genString (InJson, BSC.unpack bs)- where genString :: (JsonState, String) -> Maybe (Char, (JsonState, String))- genString (InJson, ds) = case ds of- (e:es) | e == '"' -> genString (InString , es)- (_:es) -> genString (InJson , es)- _ -> Nothing- genString (InString, ds) = case ds of- (e:es) | e == '\\' -> genString (Escaped , es)- (e:_ ) | e == '"' -> Nothing- (e:es) -> Just (e, (InString , es))- _ -> Nothing- genString (Escaped, ds) = case ds of- (_:es) -> Just ('.', (InString , es))- _ -> Nothing- genString (_, _) = Nothing+-- | Slurp a JSON string+--+-- Examples:+--+-- >>> :set -XOverloadedStrings+-- >>> slurpText "\"Hello\""+-- Right "Hello"+-- >>> slurpText "123"+-- Left "34: Failed reading: satisfy"+slurpText :: BS.ByteString -> Either Text Text+slurpText bs = case PBS.parseOnly AP.jstring bs of+ Right t -> Right t+ Left e -> Left (T.pack e) +-- | Slurp a JSON number+--+-- Examples:+--+-- >>> :set -XOverloadedStrings+-- >>> slurpNumber "123, true"+-- "123"+-- >>> slurpNumber "\"Hello\""+-- "\"Hello\"" slurpNumber :: BS.ByteString -> BS.ByteString slurpNumber bs = let (!cs, _) = BS.unfoldrN (BS.length bs) genNumber (InJson, bs) in cs where genNumber :: (JsonState, BS.ByteString) -> Maybe (Word8, (JsonState, BS.ByteString))
+ src/HaskellWorks/Data/Json/Internal/Standard/Cursor/Token.hs view
@@ -0,0 +1,24 @@++module HaskellWorks.Data.Json.Internal.Standard.Cursor.Token+ ( jsonTokenAt+ ) where++import Data.ByteString.Internal as BSI+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Drop+import HaskellWorks.Data.Json.Internal.Standard.Token.Tokenize+import HaskellWorks.Data.Json.Standard.Cursor.Generic+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) => GenericCursor 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
+ src/HaskellWorks/Data/Json/Internal/Standard/Token/Tokenize.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Data.Json.Internal.Standard.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++{- HLINT ignore "Reduce duplication" -}++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)
src/HaskellWorks/Data/Json/Internal/Token.hs view
@@ -2,4 +2,4 @@ ( module X ) where -import HaskellWorks.Data.Json.Internal.Backend.Standard.Token.Tokenize as X+import HaskellWorks.Data.Json.Internal.Standard.Token.Tokenize as X
src/HaskellWorks/Data/Json/Internal/Value.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -59,4 +58,7 @@ b <- parseHexDigit c <- parseHexDigit d <- parseHexDigit- return $ chr $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d+ let res = a `shift` 12 .|. b `shift` 8 .|. c `shift` 4 .|. d+ return $ if res <= 0x10FFFF+ then chr res+ else '�'
src/HaskellWorks/Data/Json/Internal/Word64.hs view
@@ -2,7 +2,7 @@ import Data.Word -import qualified HaskellWorks.Data.Json.Internal.Word8 as W8+import qualified HaskellWorks.Data.Json.Standard.Cursor.Internal.Word8 as W8 doubleQuote :: Word64 doubleQuote = 0x0101010101010101 * fromIntegral W8.doubleQuote
− src/HaskellWorks/Data/Json/Internal/Word8.hs
@@ -1,72 +0,0 @@-module HaskellWorks.Data.Json.Internal.Word8 where--import Data.Word-import Data.Word8 hiding (isDigit)--import qualified Data.Char as C--isLeadingDigit :: Word8 -> Bool-isLeadingDigit w = w == _hyphen || (w >= _0 && w <= _9)--isTrailingDigit :: Word8 -> Bool-isTrailingDigit w = w == _plus || w == _hyphen || (w >= _0 && w <= _9) || w == _period || w == _E || w == _e--isAlphabetic :: Word8 -> Bool-isAlphabetic w = (w >= _A && w <= _Z) || (w >= _a && w <= _z)--isDigit :: Word8 -> Bool-isDigit w = w >= _0 && w <= _9--wIsJsonNumberDigit :: Word8 -> Bool-wIsJsonNumberDigit w = (w >= _0 && w <= _9) || w == _hyphen--doubleQuote :: Word8-doubleQuote = fromIntegral (C.ord '"')--backSlash :: Word8-backSlash = fromIntegral (C.ord '\\')--openBrace :: Word8-openBrace = fromIntegral (C.ord '{')--closeBrace :: Word8-closeBrace = fromIntegral (C.ord '}')--openBracket :: Word8-openBracket = fromIntegral (C.ord '[')--closeBracket :: Word8-closeBracket = fromIntegral (C.ord ']')--comma :: Word8-comma = fromIntegral (C.ord ',')--colon :: Word8-colon = fromIntegral (C.ord ':')--isPeriod :: Word8 -> Bool-isPeriod w = w == 46--isMinus :: Word8 -> Bool-isMinus w = w == 45--isPlus :: Word8 -> Bool-isPlus w = w == 43--isValueChar :: Word8 -> Bool-isValueChar c = isAlphabetic c || isDigit c || isPeriod c || isMinus c || isPlus c--isOpen :: Word8 -> Bool-isOpen c = c == openBracket || c == openBrace--isClose :: Word8 -> Bool-isClose c = c == closeBracket || c == closeBrace--isDelim :: Word8 -> Bool-isDelim c = c == comma || c == colon--isDoubleQuote :: Word8 -> Bool-isDoubleQuote c = c == doubleQuote--isBackSlash :: Word8 -> Bool-isBackSlash c = c == backSlash
src/HaskellWorks/Data/Json/LightJson.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-}@@ -8,37 +9,58 @@ module HaskellWorks.Data.Json.LightJson where import Control.Arrow+import Control.Monad import Data.String+import Data.Text (Text)+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Drop+import HaskellWorks.Data.Json.Internal.CharLike import HaskellWorks.Data.Json.Internal.Doc+import HaskellWorks.Data.Json.Internal.Slurp+import HaskellWorks.Data.Json.Standard.Cursor.Generic import HaskellWorks.Data.MQuery import HaskellWorks.Data.MQuery.AtLeastSize import HaskellWorks.Data.MQuery.Entry import HaskellWorks.Data.MQuery.Micro import HaskellWorks.Data.MQuery.Mini import HaskellWorks.Data.MQuery.Row-import Prelude hiding (drop)-import Text.PrettyPrint.ANSI.Leijen+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 Prettyprinter -import qualified Data.ByteString as BS+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BSU+import qualified Data.List as L+import qualified Data.Text as T+import qualified HaskellWorks.Data.BalancedParens as BP+import qualified HaskellWorks.Data.Json.Simple.Cursor as JSC data LightJson c- = LightJsonString String+ = LightJsonString Text | LightJsonNumber BS.ByteString- | LightJsonObject [(String, c)]+ | LightJsonObject [(Text, c)] | LightJsonArray [c] | LightJsonBool Bool | LightJsonNull- | LightJsonError String+ | LightJsonError Text deriving Show -instance Eq (LightJson c) where+instance LightJsonAt c => Eq (LightJson c) where (==) (LightJsonString a) (LightJsonString b) = a == b (==) (LightJsonNumber a) (LightJsonNumber b) = a == b (==) (LightJsonBool a) (LightJsonBool b) = a == b+ (==) (LightJsonObject a) (LightJsonObject b) = fmap (fmap lightJsonAt) a == fmap (fmap lightJsonAt) b+ (==) (LightJsonArray a) (LightJsonArray b) = fmap lightJsonAt a == fmap lightJsonAt b (==) LightJsonNull LightJsonNull = True+ (==) (LightJsonError a) (LightJsonError b) = a == b (==) _ _ = False -data LightJsonField c = LightJsonField String (LightJson c)+data LightJsonField c = LightJsonField Text (LightJson c) class LightJsonAt a where lightJsonAt :: a -> LightJson a@@ -55,8 +77,8 @@ LightJsonArray vs -> hEncloseSep (text "[") (text "]") (text ",") ((pretty . lightJsonAt) `map` vs) LightJsonBool w -> red (text (show w)) LightJsonNull -> text "null"- LightJsonError s -> text "<error " <> text s <> text ">"- where toLightJsonField :: (String, LightJson c) -> LightJsonField c+ LightJsonError s -> text "<error " <> text (T.unpack s) <> text ">"+ where toLightJsonField :: (Text, LightJson c) -> LightJsonField c toLightJsonField (k, v) = LightJsonField k v instance Pretty (Micro (LightJson c)) where@@ -68,16 +90,18 @@ pretty (Micro (LightJsonArray _ )) = text "[..]" pretty (Micro (LightJsonBool w )) = red (text (show w)) pretty (Micro LightJsonNull ) = text "null"- pretty (Micro (LightJsonError s )) = text "<error " <> text s <> text ">"+ pretty (Micro (LightJsonError s )) = text "<error " <> text (T.unpack s) <> text ">" instance Pretty (Micro (String, LightJson c)) where pretty (Micro (fieldName, jpv)) = red (text (show fieldName)) <> text ": " <> pretty (Micro jpv) +instance Pretty (Micro (Text, LightJson c)) where+ pretty (Micro (fieldName, jpv)) = red (text (show fieldName)) <> text ": " <> pretty (Micro jpv)+ instance LightJsonAt c => Pretty (Mini (LightJson c)) where pretty mjpv = case mjpv of Mini (LightJsonString s ) -> dullgreen (text (show s)) Mini (LightJsonNumber n ) -> cyan (text (show n))- Mini (LightJsonObject [] ) -> text "{}" Mini (LightJsonObject kvs ) -> case kvs of (_:_:_:_:_:_:_:_:_:_:_:_:_) -> text "{" <> prettyKvs (map (second lightJsonAt) kvs) <> text ", ..}" [] -> text "{}"@@ -88,13 +112,57 @@ Mini (LightJsonArray _ ) -> text "[]" Mini (LightJsonBool w ) -> red (text (show w)) Mini LightJsonNull -> text "null"- Mini (LightJsonError s ) -> text "<error " <> text s <> text ">"+ Mini (LightJsonError s ) -> text "<error " <> text (T.unpack s) <> text ">" instance LightJsonAt c => Pretty (Mini (String, LightJson c)) where pretty (Mini (fieldName, jpv)) = text (show fieldName) <> text ": " <> pretty (Mini jpv) +instance LightJsonAt c => Pretty (Mini (Text, LightJson c)) where+ pretty (Mini (fieldName, jpv)) = text (show fieldName) <> text ": " <> pretty (Mini jpv)+ instance LightJsonAt c => Pretty (MQuery (LightJson c)) where pretty = pretty . Row 120 . mQuery instance LightJsonAt c => Pretty (MQuery (Entry String (LightJson c))) where pretty (MQuery das) = pretty (Row 120 das)++instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => LightJsonAt (GenericCursor BS.ByteString v w) where+ lightJsonAt k = case uncons remainder of+ Just (!c, _) | isLeadingDigit2 c -> LightJsonNumber (slurpNumber remainder)+ Just (!c, _) | isQuotDbl c -> either LightJsonError LightJsonString (slurpText remainder)+ Just (!c, _) | isChar_t c -> LightJsonBool True+ Just (!c, _) | isChar_f c -> LightJsonBool False+ Just (!c, _) | isChar_n c -> LightJsonNull+ Just (!c, _) | isBraceLeft c -> LightJsonObject (mapValuesFrom (firstChild k))+ Just (!c, _) | isBracketLeft c -> LightJsonArray (arrayValuesFrom (firstChild k))+ Just _ -> LightJsonError "Invalid Json Type"+ Nothing -> LightJsonError "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 = L.unfoldr (fmap (id &&& nextSibling))+ mapValuesFrom j = pairwise (arrayValuesFrom j) >>= asField+ pairwise (a:b:rs) = (a, b) : pairwise rs+ pairwise _ = []+ asField (a, b) = case lightJsonAt a of+ LightJsonString s -> [(s, b)]+ _ -> []++instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => LightJsonAt (JSC.JsonCursor BS.ByteString v w) where+ lightJsonAt k = if kra `mod` 2 == 1+ then let i = fromIntegral (kpa - 1) :: Int in+ if i < BS.length kt+ then case BSU.unsafeIndex kt i of+ 91 -> LightJsonArray []+ 123 -> LightJsonObject []+ _ -> LightJsonError "Invalid collection character"+ else LightJsonError "Index out of bounds"+ else LightJsonError "Unaligned cursor"+ where kpa = select1 kib kta + km+ kib = JSC.interests k+ kra = JSC.cursorRank k+ ksa = kra + 1+ kta = ksa `div` 2+ km = ksa `mod` 2+ kt = JSC.cursorText k
src/HaskellWorks/Data/Json/PartialValue.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -10,6 +9,7 @@ , JsonPartialValueAt(..) , asInteger , asString+ , asText , castAsInteger , entry , hasKey@@ -21,37 +21,69 @@ ) where import Control.Arrow+import Data.String+import Data.Text (Text)+import HaskellWorks.Data.Bits.BitWise import HaskellWorks.Data.Json.Internal.Doc import HaskellWorks.Data.Json.Internal.PartialIndex import HaskellWorks.Data.Json.Internal.Value+import HaskellWorks.Data.Json.Standard.Cursor.Generic import HaskellWorks.Data.MQuery import HaskellWorks.Data.MQuery.AtLeastSize import HaskellWorks.Data.MQuery.Entry import HaskellWorks.Data.MQuery.Micro import HaskellWorks.Data.MQuery.Mini import HaskellWorks.Data.MQuery.Row-import Text.PrettyPrint.ANSI.Leijen+import HaskellWorks.Data.RankSelect.Base.Rank0+import HaskellWorks.Data.RankSelect.Base.Rank1+import HaskellWorks.Data.RankSelect.Base.Select1+import Prelude hiding (drop)+import Prettyprinter import qualified Data.Attoparsec.ByteString.Char8 as ABC import qualified Data.ByteString as BS import qualified Data.DList as DL+import qualified Data.Text as T+import qualified HaskellWorks.Data.BalancedParens as BP +-- | Partial JSON type.+--+-- This data type has an additional 'JsonPartialError' data constructor to indicate parsing+-- errors. This allows parsing to be more lazy because parsing errors may now be expressed+-- anywhere in the parsed document so the parser no longer needs to make a verdict about whether+-- there are any parsing errors in the entire document.+--+-- See 'jsonPartialJsonValueAt' on how to parse JSON text into this datatype.+--+-- Although this data type allows for lazier parsing it doesn't allow for sub-trees to be+-- garbage collected if a reference to an ancestor node is held. To avoid holding onto+-- sub-trees that are no longer needed without having to drop references to ancestors use+-- 'HaskellWorks.Data.Json.LightJson.LightJson' instead. data JsonPartialValue- = JsonPartialString String+ = JsonPartialString Text | JsonPartialNumber Double- | JsonPartialObject [(String, JsonPartialValue)]+ | JsonPartialObject [(Text, JsonPartialValue)] | JsonPartialArray [JsonPartialValue] | JsonPartialBool Bool | JsonPartialNull- | JsonPartialError String+ | JsonPartialError Text deriving (Eq, Show, Ord) class JsonPartialValueAt a where+ -- | Get a JSON partial value from another type+ --+ -- This function can always "succeed" because the data type it returns allows for the document value+ -- to contain an arbitrary number of errors. This means errors can be reported in document nodes+ -- as parsing occurs lazily.+ --+ -- There are garbage collection implementations you may want to consider. If you would like to be+ -- able to hold onto ancestor nodes and still be able to garbage collect visited sub-trees, then+ -- consider using 'HaskellWorks.Data.Json.LightJson.lightJsonAt' instead. jsonPartialJsonValueAt :: a -> JsonPartialValue -data JsonPartialField = JsonPartialField String JsonPartialValue+data JsonPartialField = JsonPartialField Text JsonPartialValue -jsonPartialValueString :: JsonPartialValue -> String+jsonPartialValueString :: JsonPartialValue -> Text jsonPartialValueString pjv = case pjv of JsonPartialString s -> s _ -> ""@@ -59,13 +91,13 @@ instance JsonPartialValueAt JsonPartialIndex where jsonPartialJsonValueAt i = case i of JsonPartialIndexString s -> case ABC.parse parseJsonString s of- ABC.Fail {} -> JsonPartialError ("Invalid string: '" ++ show (BS.take 20 s) ++ "...'")+ ABC.Fail {} -> JsonPartialError ("Invalid string: '" <> T.pack (show (BS.take 20 s)) <> "...'") ABC.Partial _ -> JsonPartialError "Unexpected end of string"- ABC.Done _ r -> JsonPartialString r+ ABC.Done _ r -> JsonPartialString (T.pack r) -- TODO optimise JsonPartialIndexNumber s -> case ABC.parse ABC.rational s of- ABC.Fail {} -> JsonPartialError ("Invalid number: '" ++ show (BS.take 20 s) ++ "...'")+ ABC.Fail {} -> JsonPartialError ("Invalid number: '" <> T.pack (show (BS.take 20 s)) <> "...'") ABC.Partial f -> case f " " of- ABC.Fail {} -> JsonPartialError ("Invalid number: '" ++ show (BS.take 20 s) ++ "...'")+ ABC.Fail {} -> JsonPartialError ("Invalid number: '" <> T.pack (show (BS.take 20 s)) <> "...'") ABC.Partial _ -> JsonPartialError "Unexpected end of number" ABC.Done _ r -> JsonPartialNumber r ABC.Done _ r -> JsonPartialNumber r@@ -73,13 +105,13 @@ JsonPartialIndexArray es -> JsonPartialArray (map jsonPartialJsonValueAt es) JsonPartialIndexBool v -> JsonPartialBool v JsonPartialIndexNull -> JsonPartialNull- JsonPartialIndexError s -> JsonPartialError s+ JsonPartialIndexError s -> JsonPartialError (T.pack s) -- TODO optimise where parseString bs = case ABC.parse parseJsonString bs of- ABC.Fail {} -> JsonPartialError ("Invalid field: '" ++ show (BS.take 20 bs) ++ "...'")+ ABC.Fail {} -> JsonPartialError ("Invalid field: '" <> T.pack (show (BS.take 20 bs)) <> "...'") ABC.Partial _ -> JsonPartialError "Unexpected end of field"- ABC.Done _ s -> JsonPartialString s+ ABC.Done _ s -> JsonPartialString (T.pack s) -- TODO optimise -toJsonPartialField :: (String, JsonPartialValue) -> JsonPartialField+toJsonPartialField :: (Text, JsonPartialValue) -> JsonPartialField toJsonPartialField (k, v) = JsonPartialField k v instance Pretty JsonPartialField where@@ -94,7 +126,7 @@ JsonPartialArray vs -> hEncloseSep (text "[") (text "]") (text ",") (pretty `map` vs) JsonPartialBool w -> red (text (show w)) JsonPartialNull -> text "null"- JsonPartialError s -> text "<error " <> text s <> text ">"+ JsonPartialError s -> text "<error " <> text (T.unpack s) <> text ">" instance Pretty (Micro JsonPartialValue) where pretty (Micro (JsonPartialString s )) = dullgreen (text (show s))@@ -105,19 +137,21 @@ pretty (Micro (JsonPartialArray _ )) = text "[..]" pretty (Micro (JsonPartialBool w )) = red (text (show w)) pretty (Micro JsonPartialNull ) = text "null"- pretty (Micro (JsonPartialError s )) = text "<error " <> text s <> text ">"+ pretty (Micro (JsonPartialError s )) = text "<error " <> text (T.unpack s) <> text ">" instance Pretty (Micro (String, JsonPartialValue)) where pretty (Micro (fieldName, jpv)) = red (text (show fieldName)) <> text ": " <> pretty (Micro jpv) +instance Pretty (Micro (Text, JsonPartialValue)) where+ pretty (Micro (fieldName, jpv)) = red (text (show fieldName)) <> text ": " <> pretty (Micro jpv)+ instance Pretty (Mini JsonPartialValue) where pretty mjpv = case mjpv of Mini (JsonPartialString s ) -> dullgreen (text (show s)) Mini (JsonPartialNumber n ) -> cyan (text (show n))- Mini (JsonPartialObject [] ) -> text "{}" Mini (JsonPartialObject kvs ) -> case kvs of- (_:_:_:_:_:_:_:_:_:_:_:_:_) -> text "{" <> prettyKvs kvs <> text ", ..}" [] -> text "{}"+ (_:_:_:_:_:_:_:_:_:_:_:_:_) -> text "{" <> prettyKvs kvs <> text ", ..}" _ -> text "{" <> prettyKvs kvs <> text "}" Mini (JsonPartialArray [] ) -> text "[]" Mini (JsonPartialArray vs ) | vs `atLeastSize` 11 -> text "[" <> nest 2 (prettyVs (Micro `map` take 10 vs)) <> text ", ..]"@@ -125,18 +159,21 @@ Mini (JsonPartialArray _ ) -> text "[]" Mini (JsonPartialBool w ) -> red (text (show w)) Mini JsonPartialNull -> text "null"- Mini (JsonPartialError s ) -> text "<error " <> text s <> text ">"+ Mini (JsonPartialError s ) -> text "<error " <> text (T.unpack s) <> text ">" -instance Pretty (Mini (String, JsonPartialValue)) where+instance Pretty (Mini (Text, JsonPartialValue)) where pretty (Mini (fieldName, jpv)) = text (show fieldName) <> text ": " <> pretty (Mini jpv) instance Pretty (MQuery JsonPartialValue) where pretty = pretty . Row 120 . mQuery -instance Pretty (MQuery (Entry String JsonPartialValue)) where+instance Pretty (MQuery (Entry Text JsonPartialValue)) where pretty (MQuery das) = pretty (Row 120 das) -hasKV :: String -> JsonPartialValue -> JsonPartialValue -> MQuery JsonPartialValue+instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => JsonPartialValueAt (GenericCursor BS.ByteString v w) where+ jsonPartialJsonValueAt = jsonPartialJsonValueAt . jsonPartialIndexAt++hasKV :: Text -> JsonPartialValue -> JsonPartialValue -> MQuery JsonPartialValue hasKV k v (JsonPartialObject xs) = if (k, v) `elem` xs then MQuery (DL.singleton (JsonPartialObject xs)) else MQuery DL.empty hasKV _ _ _ = MQuery DL.empty @@ -145,13 +182,18 @@ JsonPartialArray es -> MQuery $ DL.fromList es _ -> MQuery DL.empty -entry :: JsonPartialValue -> MQuery (Entry String JsonPartialValue)+entry :: JsonPartialValue -> MQuery (Entry Text JsonPartialValue) entry jpv = case jpv of JsonPartialObject fs -> MQuery $ DL.fromList (uncurry Entry `map` fs) _ -> MQuery DL.empty asString :: JsonPartialValue -> MQuery String asString jpv = case jpv of+ JsonPartialString s -> MQuery $ DL.singleton (T.unpack s)+ _ -> MQuery DL.empty++asText :: JsonPartialValue -> MQuery Text+asText jpv = case jpv of JsonPartialString s -> MQuery $ DL.singleton s _ -> MQuery DL.empty @@ -162,20 +204,20 @@ castAsInteger :: JsonPartialValue -> MQuery Integer castAsInteger jpv = case jpv of- JsonPartialString n -> MQuery $ DL.singleton (read n)+ JsonPartialString n -> MQuery $ DL.singleton (read (T.unpack n)) JsonPartialNumber n -> MQuery $ DL.singleton (floor n) _ -> MQuery DL.empty -named :: String -> Entry String JsonPartialValue -> MQuery JsonPartialValue+named :: Text -> Entry Text JsonPartialValue -> MQuery JsonPartialValue named fieldName (Entry fieldName' jpv) | fieldName == fieldName' = MQuery $ DL.singleton jpv named _ _ = MQuery DL.empty -jsonKeys :: JsonPartialValue -> [String]+jsonKeys :: JsonPartialValue -> [Text] jsonKeys jpv = case jpv of JsonPartialObject fs -> fst `map` fs _ -> [] -hasKey :: String -> JsonPartialValue -> Bool+hasKey :: Text -> JsonPartialValue -> Bool hasKey fieldName jpv = fieldName `elem` jsonKeys jpv jsonSize :: JsonPartialValue -> MQuery JsonPartialValue
src/HaskellWorks/Data/Json/Query.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -8,7 +7,7 @@ module HaskellWorks.Data.Json.Query where import Control.Arrow-import Data.String+import Data.Text (Text) import HaskellWorks.Data.Json.LightJson import HaskellWorks.Data.MQuery import HaskellWorks.Data.MQuery.Entry@@ -16,18 +15,19 @@ import qualified Data.Attoparsec.ByteString.Char8 as ABC import qualified Data.DList as DL+import qualified Data.Text as T item :: LightJsonAt c => LightJson c -> MQuery (LightJson c) item jpv = case jpv of LightJsonArray es -> MQuery $ DL.fromList (lightJsonAt `map` es) _ -> MQuery DL.empty -entry :: LightJsonAt c => LightJson c -> MQuery (Entry String (LightJson c))+entry :: LightJsonAt c => LightJson c -> MQuery (Entry Text (LightJson c)) entry jpv = case jpv of LightJsonObject fs -> MQuery $ DL.fromList ((uncurry Entry . second lightJsonAt) `map` fs) _ -> MQuery DL.empty -asString :: LightJson c -> MQuery String+asString :: LightJson c -> MQuery Text asString jpv = case jpv of LightJsonString s -> MQuery $ DL.singleton s _ -> MQuery DL.empty@@ -50,20 +50,20 @@ castAsInteger :: LightJson c -> MQuery Integer castAsInteger jpv = case jpv of- LightJsonString n -> MQuery $ DL.singleton (read n)+ LightJsonString n -> MQuery $ DL.singleton (read (T.unpack n)) -- TODO Optimise LightJsonNumber _ -> asInteger jpv _ -> MQuery DL.empty -named :: String -> Entry String (LightJson c) -> MQuery (LightJson c)+named :: Text -> Entry Text (LightJson c) -> MQuery (LightJson c) named fieldName (Entry fieldName' jpv) | fieldName == fieldName' = MQuery $ DL.singleton jpv named _ _ = MQuery DL.empty -jsonKeys :: LightJson c -> [String]+jsonKeys :: LightJson c -> [Text] jsonKeys jpv = case jpv of LightJsonObject fs -> fst `map` fs _ -> [] -hasKey :: String -> LightJson c -> Bool+hasKey :: Text -> LightJson c -> Bool hasKey fieldName jpv = fieldName `elem` jsonKeys jpv jsonSize :: LightJson c -> MQuery Integer
+ src/HaskellWorks/Data/Json/Simple/Value.hs view
@@ -0,0 +1,42 @@+module HaskellWorks.Data.Json.Simple.Value where++import Data.Maybe+import HaskellWorks.Data.Json.Simple.Cursor+import HaskellWorks.Data.Positioning+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.RankSelect.CsPoppy++import qualified Data.ByteString as BS+import qualified HaskellWorks.Data.BalancedParens as BP+import qualified HaskellWorks.Data.BalancedParens.RangeMin as RM++data JsonValue+ = JsonValues JsonValues+ | JsonNull+ | JsonNumber Double+ | JsonString String+ | JsonBoolean Bool+ deriving (Eq, Show)++data JsonValues+ = JsonArray [JsonValue]+ | JsonObject [(String, JsonValue)]+ deriving (Eq, Show)++snippetPos :: JsonCursor BS.ByteString CsPoppy (RM.RangeMin CsPoppy) -> (Count, Count)+snippetPos k = (kpa, kpz)+ where kpa = select1 kib kta + km+ kpz = select1 kib ktz - km+ kib = interests k+ kbp = balancedParens k+ kra = cursorRank k+ krz = fromMaybe maxBound (BP.findClose kbp kra)+ ksa = kra + 1+ ksz = krz + 1+ kta = ksa `div` 2+ ktz = ksz `div` 2+ km = ksa `mod` 2++snippet :: JsonCursor BS.ByteString CsPoppy (RM.RangeMin CsPoppy) -> BS.ByteString+snippet k = let (a, z) = snippetPos k in BS.take (fromIntegral (z - a + 1)) (BS.drop (fromIntegral (a - 1)) kt)+ where kt = cursorText k
+ src/HaskellWorks/Data/Json/Standard/Load/Partial.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.Json.Standard.Load.Partial+ ( loadPartial+ , loadPartialWithCsPoppyIndex+ , loadPartialWithIndex+ ) where++import HaskellWorks.Data.BalancedParens.Simple+import HaskellWorks.Data.Bits.BitShown+import HaskellWorks.Data.Json.Internal.PartialIndex+import HaskellWorks.Data.Json.PartialValue+import HaskellWorks.Data.Json.Standard.Cursor.Generic+import HaskellWorks.Data.Json.Standard.Cursor.Load.Raw+import HaskellWorks.Data.RankSelect.CsPoppy++loadPartialWithIndex :: String -> IO JsonPartialValue+loadPartialWithIndex filename = do+ (jsonBS, jsonIb, jsonBp) <- loadRawWithIndex filename+ let cursor = GenericCursor jsonBS (BitShown jsonIb) (SimpleBalancedParens jsonBp) 1+ let !jsonResult = jsonPartialJsonValueAt (jsonPartialIndexAt cursor)+ return jsonResult++loadPartialWithCsPoppyIndex :: String -> IO JsonPartialValue+loadPartialWithCsPoppyIndex filename = do+ (jsonBS, jsonIb, jsonBp) <- loadRawWithIndex filename+ let cursor = GenericCursor jsonBS (makeCsPoppy jsonIb) (SimpleBalancedParens jsonBp) 1+ let !jsonResult = jsonPartialJsonValueAt (jsonPartialIndexAt cursor)+ return jsonResult++loadPartial :: String -> IO JsonPartialValue+loadPartial = loadPartialWithCsPoppyIndex
− src/HaskellWorks/Data/Json/Type.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module HaskellWorks.Data.Json.Type- ( JsonType(..)- , JsonTypeAt(..)- ) where--import HaskellWorks.Data.Positioning-import Prelude hiding (drop)--{-# ANN module ("HLint: Reduce duplication" :: String) #-}--data JsonType- = JsonTypeArray- | JsonTypeBool- | JsonTypeNull- | JsonTypeNumber- | JsonTypeObject- | JsonTypeString- deriving (Eq, Show)--class JsonTypeAt a where- jsonTypeAtPosition :: Position -> a -> Maybe JsonType- jsonTypeAt :: a -> Maybe JsonType
src/HaskellWorks/Data/Json/Value.hs view
@@ -1,28 +1,51 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module HaskellWorks.Data.Json.Value where +import Data.Text (Text) import HaskellWorks.Data.Json.DecodeError 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+import qualified Data.Text as T +-- | Traditional JSON type.+--+-- This type has the a constructor per JSON data type as is typical for JSON in most libraries.+--+-- See 'jsonValueAt' on how to parse JSON text into this datatype.+--+-- Although Haskell data types are lazy by default, you will not get a fully lazy data structure+-- when parsing to this type because there is no way to express parsing errors in this datatype.+--+-- For a data type that gives you lazier behaviour, see other alternatives such as+-- 'HaskellWorks.Data.Json.PartialValue.JsonPartialValue' or 'HaskellWorks.Data.Json.LightJson.LightJson'. data JsonValue- = JsonString String+ = JsonString Text | JsonNumber Double- | JsonObject [(String, JsonValue)]+ | JsonObject [(Text, JsonValue)] | JsonArray [JsonValue] | JsonBool Bool | JsonNull deriving (Eq, Show) class JsonValueAt a where+ -- | Get a JSON value from another type+ --+ -- The @hw-json@ library does not do full JSON validation for efficiency reasons, but parsing can+ -- fail if the JSON is malformed. When parsing fails, then 'Left' will be returned.+ --+ -- If 'Right' is returned then that means there are no parsing failures, which implies "knowing"+ -- that there parsing failures in the entire document, which implies that pattern matching on+ -- 'Right' evaluates the entire document.+ --+ -- This limits the laziness of the JSON parsing. For lazier alternatives, see+ -- 'HaskellWorks.Data.Json.PartialValue.jsonPartialJsonValueAt' or 'HaskellWorks.Data.Json.LightJson.lightJsonAt'. jsonValueAt :: a -> Either DecodeError JsonValue instance JsonValueAt JsonIndex where@@ -30,7 +53,7 @@ JsonIndexString s -> case ABC.parse parseJsonString s of ABC.Fail {} -> Left (DecodeError ("Invalid string: '" ++ show (BS.take 20 s) ++ "...'")) ABC.Partial _ -> Left (DecodeError "Unexpected end of string")- ABC.Done _ r -> Right (JsonString r)+ ABC.Done _ r -> Right (JsonString (T.pack r)) -- TODO optimise JsonIndexNumber s -> case ABC.parse ABC.rational s of ABC.Fail {} -> Left (DecodeError ("Invalid number: '" ++ show (BS.take 20 s) ++ "...'")) ABC.Partial f -> case f " " of@@ -38,11 +61,12 @@ ABC.Partial _ -> Left (DecodeError "Unexpected end of number") ABC.Done _ r -> Right (JsonNumber r) ABC.Done _ r -> Right (JsonNumber r)- JsonIndexObject fs -> JsonObject <$> mapM (\f -> (,) <$> parseString (fst f) <*> jsonValueAt (snd f)) fs+ JsonIndexObject fs -> JsonObject <$> mapM (\f -> (,) <$> parseText (fst f) <*> jsonValueAt (snd f)) fs JsonIndexArray es -> JsonArray <$> mapM jsonValueAt es JsonIndexBool v -> Right (JsonBool v) JsonIndexNull -> Right JsonNull- where parseString bs = case ABC.parse parseJsonString bs of+ where parseText bs = T.pack <$> parseString bs -- TODO optimise+ parseString bs = case ABC.parse parseJsonString bs of ABC.Fail {} -> Left (DecodeError ("Invalid field: '" ++ show (BS.take 20 bs) ++ "...'")) ABC.Partial _ -> Left (DecodeError "Unexpected end of field") ABC.Done _ s -> Right s
− test/HaskellWorks/Data/Json/Backend/Simple/CursorSpec.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -fno-warn-missing-signatures #-}--module HaskellWorks.Data.Json.Backend.Simple.CursorSpec- ( spec- ) where--import Control.Monad-import HaskellWorks.Hspec.Hedgehog-import Hedgehog-import Test.Hspec--import qualified Data.ByteString as BS-import qualified HaskellWorks.Data.Json.Backend.Simple.Cursor as Z-import qualified HaskellWorks.Data.Json.Backend.Simple.Fast as FAST-import qualified HaskellWorks.Data.Json.Backend.Simple.Value as V-import qualified HaskellWorks.Data.TreeCursor as TC--{-# ANN module ("HLint: ignore Redundant do" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}-{-# ANN module ("HLint: redundant bracket" :: String) #-}--fc = TC.firstChild-ns = TC.nextSibling--spec :: Spec-spec = describe "HaskellWorks.Data.Json.Backend.Simple.CursorSpec" $ do- describe "Json cursor" $ do- describe "For sample Json" $ do- let k = FAST.makeCursor ("[[11],[22]]" :: BS.ByteString)- -- [ [ 1 1 ] , [ 2 2 ] ]- -- (( (( )) )( (( )) ))- it "can navigate" $ requireTest $ do- (Z.cursorRank <$> Just k) === Just 1- (Z.cursorRank <$> ns k) === Nothing- (Z.cursorRank <$> fc k) === Just 2- (Z.cursorRank <$> (fc >=> ns ) k) === Just 8- (Z.cursorRank <$> (fc >=> ns >=> fc ) k) === Just 9- (Z.cursorRank <$> (fc >=> ns >=> fc >=> ns ) k) === Nothing- (Z.cursorRank <$> (fc >=> ns >=> fc >=> fc ) k) === Just 10- (Z.cursorRank <$> (fc >=> ns >=> fc >=> fc >=> ns) k) === Nothing- (Z.cursorRank <$> (fc >=> ns >=> fc >=> fc >=> fc) k) === Nothing- (Z.cursorRank <$> (fc >=> fc ) k) === Just 3- (Z.cursorRank <$> (fc >=> fc >=> ns ) k) === Nothing- (Z.cursorRank <$> (fc >=> fc >=> fc ) k) === Just 4- (Z.cursorRank <$> (fc >=> fc >=> fc >=> ns ) k) === Nothing- (Z.cursorRank <$> (fc >=> fc >=> fc >=> fc ) k) === Nothing- it "can snippet pos" $ requireTest $ do- (V.snippetPos <$> Just k) === Just (1, 11)- (V.snippetPos <$> ns k) === Nothing- (V.snippetPos <$> fc k) === Just (2, 5)- (V.snippetPos <$> (fc >=> ns ) k) === Just (7, 10)- (V.snippetPos <$> (fc >=> ns >=> fc ) k) === Just (7, 10)- (V.snippetPos <$> (fc >=> ns >=> fc >=> ns ) k) === Nothing- (V.snippetPos <$> (fc >=> ns >=> fc >=> fc ) k) === Just (8, 9)- (V.snippetPos <$> (fc >=> ns >=> fc >=> fc >=> ns) k) === Nothing- (V.snippetPos <$> (fc >=> ns >=> fc >=> fc >=> fc) k) === Nothing- (V.snippetPos <$> (fc >=> fc ) k) === Just (2, 5)- (V.snippetPos <$> (fc >=> fc >=> ns ) k) === Nothing- (V.snippetPos <$> (fc >=> fc >=> fc ) k) === Just (3, 4)- (V.snippetPos <$> (fc >=> fc >=> fc >=> ns ) k) === Nothing- (V.snippetPos <$> (fc >=> fc >=> fc >=> fc ) k) === Nothing- it "can snippet" $ requireTest $ do- (V.snippet <$> Just k) === Just "[[11],[22]]"- (V.snippet <$> ns k) === Nothing- (V.snippet <$> fc k) === Just "[11]"- (V.snippet <$> (fc >=> ns ) k) === Just "[22]"- (V.snippet <$> (fc >=> ns >=> fc ) k) === Just "[22]"- (V.snippet <$> (fc >=> ns >=> fc >=> ns ) k) === Nothing- (V.snippet <$> (fc >=> ns >=> fc >=> fc ) k) === Just "22"- (V.snippet <$> (fc >=> ns >=> fc >=> fc >=> ns) k) === Nothing- (V.snippet <$> (fc >=> ns >=> fc >=> fc >=> fc) k) === Nothing- (V.snippet <$> (fc >=> fc ) k) === Just "[11]"- (V.snippet <$> (fc >=> fc >=> ns ) k) === Nothing- (V.snippet <$> (fc >=> fc >=> fc ) k) === Just "11"- (V.snippet <$> (fc >=> fc >=> fc >=> ns ) k) === Nothing- (V.snippet <$> (fc >=> fc >=> fc >=> fc ) k) === Nothing
− test/HaskellWorks/Data/Json/Backend/Standard/Succinct/Cursor/BalancedParensSpec.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}---module HaskellWorks.Data.Json.Backend.Standard.Succinct.Cursor.BalancedParensSpec- ( spec- ) where--import Data.Word-import HaskellWorks.Data.Bits.BitShow-import HaskellWorks.Hspec.Hedgehog-import Hedgehog-import Test.Hspec--import qualified Data.ByteString as BS-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.Json.Backend.Standard.SemiIndex as SI--{-# ANN module ("HLint: ignore Redundant do" :: String) #-}--balancedParensOf2 :: BS.ByteString -> DVS.Vector Word64-balancedParensOf2 bs = let SI.SemiIndex _ bp = SI.buildSemiIndex bs in bp--spec :: Spec-spec = describe "HaskellWorks.Data.Json.Succinct.Cursor.InterestBitsSpec" $ do- it "Evaluating interest bits 2" $ requireTest $ do- bitShow (balancedParensOf2 "" ) === ""- bitShow (balancedParensOf2 " \n \r \t ") === ""- bitShow (balancedParensOf2 "1234 " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (balancedParensOf2 "1.1 " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (balancedParensOf2 "-1.1e-1 " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (balancedParensOf2 "false " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (balancedParensOf2 "true " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (balancedParensOf2 "\"hello\" " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (balancedParensOf2 "\"\\\"\" " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (balancedParensOf2 "{ " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (balancedParensOf2 "} " ) === "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (balancedParensOf2 "[ " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (balancedParensOf2 "] " ) === "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (balancedParensOf2 ": " ) === ""- bitShow (balancedParensOf2 ", " ) === ""- bitShow (balancedParensOf2 "{{}}" ) === "11000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (balancedParensOf2 " { { } } " ) === "11000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"
− test/HaskellWorks/Data/Json/Backend/Standard/Succinct/Cursor/InterestBitsSpec.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}---module HaskellWorks.Data.Json.Backend.Standard.Succinct.Cursor.InterestBitsSpec(spec) where--import Data.String-import Data.Word-import HaskellWorks.Data.Bits.BitShow-import HaskellWorks.Data.Bits.BitShown-import HaskellWorks.Hspec.Hedgehog-import Hedgehog-import Test.Hspec--import qualified Data.ByteString as BS-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.Json.Backend.Standard.SemiIndex as SI-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.BlankedJson as J-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.ToInterestBits64 as J--{-# ANN module ("HLint: ignore Redundant do" :: String) #-}--interestBitsOf :: BS.ByteString -> DVS.Vector Word64-interestBitsOf bs = J.toInterestBits64 (J.toBlankedJsonTyped bs)--interestBitsOf2 :: BS.ByteString -> DVS.Vector Word64-interestBitsOf2 bs = let SI.SemiIndex ib _ = SI.buildSemiIndex bs in ib--spec :: Spec-spec = describe "HaskellWorks.Data.Json.Succinct.Cursor.InterestBitsSpec" $ do- it "Evaluating interest bits" $ requireTest $ do- BitShown (interestBitsOf "" ) === fromString ""- BitShown (interestBitsOf " \n \r \t ") === fromString "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf "1234 " ) === fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf "1.1 " ) === fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf "-1.1e-2 " ) === fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf "false " ) === fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf "true " ) === fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf "\"hello\" " ) === fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf "\"\\\"\" " ) === fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf "{ " ) === fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf "} " ) === fromString "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf "[ " ) === fromString "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf "] " ) === fromString "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf ": " ) === fromString "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf ", " ) === fromString "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf "{{}}" ) === fromString "11000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- BitShown (interestBitsOf " { { } } " ) === fromString "01010000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- it "Evaluating interest bits 2" $ requireTest $ do- bitShow (interestBitsOf2 "" ) === ""- bitShow (interestBitsOf2 " \n \r \t ") === "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "1234 " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "1.1 " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "-1.1 " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "-1.1e-2 " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "false " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "true " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "\"hello\" " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "\"\\\"\" " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "{ " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "} " ) === "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "[ " ) === "10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "] " ) === "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 ": " ) === "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 ", " ) === "00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 "{{}}" ) === "11000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"- bitShow (interestBitsOf2 " { { } } " ) === "01010000 00000000 00000000 00000000 00000000 00000000 00000000 00000000"
− test/HaskellWorks/Data/Json/Backend/Standard/Succinct/CursorSpec.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -fno-warn-missing-signatures #-}--module HaskellWorks.Data.Json.Backend.Standard.Succinct.CursorSpec(spec) where--import Data.Word-import HaskellWorks.Data.BalancedParens.Simple-import HaskellWorks.Data.Json.Backend.Standard.Cursor-import HaskellWorks.Data.Json.Backend.Standard.Succinct.GenCursorTest-import HaskellWorks.Data.RankSelect.Poppy512-import Test.Hspec--import qualified Data.ByteString as BS-import qualified Data.Vector.Storable as DVS-import qualified HaskellWorks.Data.Json.Backend.Standard.Fast as FAST-import qualified HaskellWorks.Data.Json.Backend.Standard.Slow as SLOW--{-# ANN module ("HLint: ignore Redundant do" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}-{-# ANN module ("HLint: redundant bracket" :: String) #-}--spec :: Spec-spec = describe "HaskellWorks.Data.Json.Succinct.CursorSpec" $ do- genTest "DVS.Vector Word64" (SLOW.makeCursor :: String -> JsonCursor BS.ByteString (DVS.Vector Word64) (SimpleBalancedParens (DVS.Vector Word64)))- genTest "Poppy512" (FAST.makeCursor :: String -> JsonCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64)))
− test/HaskellWorks/Data/Json/Backend/Standard/Succinct/GenCursorTest.hs
@@ -1,103 +0,0 @@-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -fno-warn-missing-signatures #-}--module HaskellWorks.Data.Json.Backend.Standard.Succinct.GenCursorTest(genTest) where--import Control.Monad-import HaskellWorks.Data.BalancedParens.BalancedParens-import HaskellWorks.Data.Bits.BitWise-import HaskellWorks.Data.Json.Backend.Standard.Cursor-import HaskellWorks.Data.Json.Internal.Backend.Standard.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-import HaskellWorks.Hspec.Hedgehog-import Hedgehog-import Test.Hspec--import qualified Data.ByteString as BS-import qualified HaskellWorks.Data.TreeCursor as TC--{-# ANN module ("HLint: ignore Redundant do" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}-{-# ANN module ("HLint: redundant bracket" :: String) #-}--fc = TC.firstChild-ns = TC.nextSibling-pn = TC.parent-ss = TC.subtreeSize--genTest :: forall t u.- ( Eq t- , Show t- , Select1 t- , Eq u- , Show u- , Rank0 u- , Rank1 u- , BalancedParens u- , TestBit u)- => String -> (String -> JsonCursor BS.ByteString t u) -> SpecWith ()-genTest t mkCursor = do- describe ("Json cursor of type " ++ t) $ do- describe "For empty json array" $ do- let cursor = mkCursor "[null]"- it "can navigate down and forwards" $ requireTest $ do- jsonIndexAt cursor === Right (JsonIndexArray [JsonIndexNull])- describe "For sample Json" $ do- let cursor = mkCursor "\- \{ \- \ \"widget\": { \- \ \"debug\": \"on\", \- \ \"window\": { \- \ \"name\": \"main_window\", \- \ \"dimensions\": [500, 600.01e-02, true, false, null] \- \ } \- \ } \- \}"- it "can navigate up" $ requireTest $ do- ( pn) cursor === Nothing- (fc >=> pn) cursor === Just cursor- (fc >=> ns >=> pn) cursor === Just cursor- (fc >=> ns >=> fc >=> pn) cursor === (fc >=> ns ) cursor- (fc >=> ns >=> fc >=> ns >=> pn) cursor === (fc >=> ns ) cursor- (fc >=> ns >=> fc >=> ns >=> ns >=> pn) cursor === (fc >=> ns ) cursor- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor === (fc >=> ns ) cursor- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor- it "can get subtree size" $ requireTest $ do- ( ss) cursor === Just 16- (fc >=> ss) cursor === Just 1- (fc >=> ns >=> ss) cursor === Just 14- (fc >=> ns >=> fc >=> ss) cursor === Just 1- (fc >=> ns >=> fc >=> ns >=> ss) cursor === Just 1- (fc >=> ns >=> fc >=> ns >=> ns >=> ss) cursor === Just 1- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> ss) cursor === Just 10- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ss) cursor === Just 1- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ss) cursor === Just 1- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ss) cursor === Just 1- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> ss) cursor === Just 6- it "can get token at cursor" $ requireTest $ do- (jsonTokenAt ) cursor === Just (JsonTokenBraceL )- (fc >=> jsonTokenAt) cursor === Just (JsonTokenString "widget" )- (fc >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenBraceL )- (fc >=> ns >=> fc >=> jsonTokenAt) cursor === Just (JsonTokenString "debug" )- (fc >=> ns >=> fc >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenString "on" )- (fc >=> ns >=> fc >=> ns >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenString "window" )- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenBraceL )- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> jsonTokenAt) cursor === Just (JsonTokenString "name" )- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenString "main_window" )- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenString "dimensions" )- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenBracketL )
− test/HaskellWorks/Data/Json/CorpusSpec.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -fno-warn-missing-signatures #-}--module HaskellWorks.Data.Json.CorpusSpec(spec) where--import Control.Monad.IO.Class-import HaskellWorks.Data.BalancedParens.Simple-import HaskellWorks.Data.Bits.FromBitTextByteString-import HaskellWorks.Data.Json.Backend.Standard.Cursor-import HaskellWorks.Hspec.Hedgehog-import Hedgehog-import Test.Hspec--import qualified Data.ByteString as BS-import qualified HaskellWorks.Data.Json.Backend.Standard.Slow as SLOW--{-# ANN module ("HLint: ignore Redundant do" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}-{-# ANN module ("HLint: redundant bracket" :: String) #-}--spec :: Spec-spec = describe "HaskellWorks.Data.Json.Corpus" $ do- it "Corpus 5000B loads properly" $ requireTest $ do- inJsonBS <- liftIO $ BS.readFile "corpus/5000B.json"- inInterestBitsBS <- liftIO $ BS.readFile "corpus/5000B.json.ib.idx"- inInterestBalancedParensBS <- liftIO $ BS.readFile "corpus/5000B.json.bp.idx"- let inInterestBits = fromBitTextByteString inInterestBitsBS- let inInterestBalancedParens = fromBitTextByteString inInterestBalancedParensBS- let !cursor = SLOW.makeCursor inJsonBS- let text = cursorText cursor- let ib = interests cursor- let SimpleBalancedParens bp = balancedParens cursor- text === inJsonBS- ib === inInterestBits- bp === inInterestBalancedParens- it "issue-0001 loads properly" $ requireTest $ do- inJsonBS <- liftIO $ BS.readFile "corpus/issue-0001.json"- inInterestBitsBS <- liftIO $ BS.readFile "corpus/issue-0001.json.ib.idx"- inInterestBalancedParensBS <- liftIO $ BS.readFile "corpus/issue-0001.json.bp.idx"- let inInterestBits = fromBitTextByteString inInterestBitsBS- let inInterestBalancedParens = fromBitTextByteString inInterestBalancedParensBS- let !cursor = SLOW.makeCursor inJsonBS- let text = cursorText cursor- let ib = interests cursor- let SimpleBalancedParens bp = balancedParens cursor- text === inJsonBS- ib === inInterestBits- bp === inInterestBalancedParens
− test/HaskellWorks/Data/Json/Internal/BlankSpec.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module HaskellWorks.Data.Json.Internal.BlankSpec (spec) where--import HaskellWorks.Data.Json.Internal.Backend.Standard.Blank-import HaskellWorks.Hspec.Hedgehog-import Hedgehog-import Test.Hspec--import qualified Data.ByteString as BS--{-# ANN module ("HLint: ignore Redundant do" :: String) #-}--whenBlankedJsonShouldBe :: BS.ByteString -> BS.ByteString -> Spec-whenBlankedJsonShouldBe original expected = do- it (show original ++ " when blanked json should be " ++ show expected) $ requireTest $ do- BS.concat (blankJson [original]) === expected--spec :: Spec-spec = describe "HaskellWorks.Data.Json.Internal.BlankSpec" $ do- describe "Can blank json" $ do- "\"\"" `whenBlankedJsonShouldBe` "()"- "\"\\\\\"" `whenBlankedJsonShouldBe` "( )"- "\"\\\\\\\"" `whenBlankedJsonShouldBe` "( "- "\" \\\\\\\"" `whenBlankedJsonShouldBe` "( "- "\" \\n\\\\\"" `whenBlankedJsonShouldBe` "( )"- "" `whenBlankedJsonShouldBe` ""- "\"\"" `whenBlankedJsonShouldBe` "()"- "\" \"" `whenBlankedJsonShouldBe` "( )"- "\" a \"" `whenBlankedJsonShouldBe` "( )"- " \"a \" x" `whenBlankedJsonShouldBe` " ( ) x"- " \"\"\"\" " `whenBlankedJsonShouldBe` " ()() "- " [][] " `whenBlankedJsonShouldBe` " [][] "- " {}{} " `whenBlankedJsonShouldBe` " {}{} "- " \"a\"b\"c\"d" `whenBlankedJsonShouldBe` " ( )b( )d"- "" `whenBlankedJsonShouldBe` ""- "1" `whenBlankedJsonShouldBe` "1"- "11" `whenBlankedJsonShouldBe` "10"- "00" `whenBlankedJsonShouldBe` "10"- "00" `whenBlankedJsonShouldBe` "10"- "-0.12e+34" `whenBlankedJsonShouldBe` "100000000"- "10.12E-34 " `whenBlankedJsonShouldBe` "100000000 "- "10.12E-34 12" `whenBlankedJsonShouldBe` "100000000 10"- " 10.12E-34 -1" `whenBlankedJsonShouldBe` " 100000000 10"- "" `whenBlankedJsonShouldBe` ""- "a" `whenBlankedJsonShouldBe` "a"- "z" `whenBlankedJsonShouldBe` "z"- " Aaa " `whenBlankedJsonShouldBe` " A__ "- " Za def " `whenBlankedJsonShouldBe` " Z_ d__ "- "" `whenBlankedJsonShouldBe` ""- " { \"ff\": 1.0, [\"\", true], null}" `whenBlankedJsonShouldBe` " { ( ): 100, [(), t___], n___}"
+ test/HaskellWorks/Data/Json/LightJsonSpec.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module HaskellWorks.Data.Json.LightJsonSpec (spec) where++import Control.Monad+import Data.Text+import HaskellWorks.Data.BalancedParens.BalancedParens+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Json.DecodeError+import HaskellWorks.Data.Json.LightJson+import HaskellWorks.Data.Json.Standard.Cursor.Generic+import HaskellWorks.Data.Json.Value+import HaskellWorks.Data.RankSelect.Base.Rank0+import HaskellWorks.Data.RankSelect.Base.Rank1+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified Data.Aeson.Parser.Internal as AP+import qualified Data.Attoparsec.ByteString as PBS+import qualified Data.ByteString as BS+import qualified Data.Scientific as S+import qualified Data.Text as T+import qualified HaskellWorks.Data.Json.Standard.Cursor.Fast as FAST+import qualified HaskellWorks.Data.Json.Standard.Cursor.Slow as SLOW+import qualified HaskellWorks.Data.TreeCursor as TC++{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant bracket" -}+{- HLINT ignore "Redundant do" -}++fc :: TC.TreeCursor k => k -> Maybe k+fc = TC.firstChild++ns :: TC.TreeCursor k => k -> Maybe k+ns = TC.nextSibling++spec :: Spec+spec = describe "HaskellWorks.Data.Json.LightJsonSpec" $ do+ genSpec "DVS.Vector Word64" SLOW.fromString+ genSpec "CsPoppy" FAST.fromString++jsonValueVia :: forall t u.+ ( BalancedParens u+ , Rank0 u+ , Rank1 u+ , Select1 t+ , TestBit u)+ => Maybe (GenericCursor BS.ByteString t u)+ -> Either DecodeError JsonValue+jsonValueVia mk = case mk of+ Just k -> case lightJsonAt k of+ LightJsonString t -> Right (JsonString t)+ LightJsonNumber bs -> case PBS.parseOnly AP.scientific bs of+ Right s -> Right (JsonNumber (S.toRealFloat s))+ Left msg -> Left (DecodeError msg)+ LightJsonObject ps -> fmap JsonObject (traverse fields ps)+ LightJsonArray cs -> fmap JsonArray (traverse elements cs)+ LightJsonBool v -> Right (JsonBool v)+ LightJsonNull -> Right JsonNull+ LightJsonError msg -> Left (DecodeError (T.unpack msg))+ Nothing -> Left (DecodeError "No such element")+ where fields :: (Text, GenericCursor BS.ByteString t u) -> Either DecodeError (Text, JsonValue)+ fields (f, c) = (f,) <$> jsonValueVia (Just c)+ elements :: GenericCursor BS.ByteString t u -> Either DecodeError JsonValue+ elements c = jsonValueVia (Just c)++genSpec :: forall t u.+ ( Select1 t+ , Rank0 u+ , Rank1 u+ , BalancedParens u+ , TestBit u)+ => String -> (String -> GenericCursor BS.ByteString t u) -> SpecWith ()+genSpec t makeCursor = do+ describe ("Json cursor of type " ++ t) $ do+ let forJson s f = describe ("of value " ++ Prelude.show s) (f (makeCursor s))+ forJson "{}" $ \cursor -> do+ it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonObject [])+ forJson " {}" $ \cursor -> do+ it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonObject [])+ forJson "1234" $ \cursor -> do+ it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonNumber 1234)+ forJson "\"Hello\"" $ \cursor -> do+ it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonString "Hello")+ forJson "[]" $ \cursor -> do+ it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonArray [])+ forJson "true" $ \cursor -> do+ it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonBool True)+ forJson "false" $ \cursor -> do+ it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonBool False)+ forJson "null" $ \cursor -> do+ it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right JsonNull+ forJson "[null]" $ \cursor -> do+ it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonArray [JsonNull])+ it "should have correct value" $ requireTest $ jsonValueVia (fc cursor) === Right JsonNull+ forJson "\"codepoint\\u2019s\"" $ \cursor -> do+ it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonString "codepoint’s")+ forJson "[null, {\"field\": 1}]" $ \cursor -> do+ it "cursor can navigate to second child of array" $ requireTest $ do+ jsonValueVia ((fc >=> ns) cursor) === Right ( JsonObject [("field", JsonNumber 1)] )+ jsonValueVia (Just cursor) === Right (JsonArray [JsonNull, JsonObject [("field", JsonNumber 1)]])+ describe "For empty json array" $ do+ let cursor = makeCursor "[]"+ it "can navigate down and forwards" $ requireTest $ do+ jsonValueVia (Just cursor) === Right (JsonArray [])+ describe "For empty json array" $ do+ let cursor = makeCursor "[null]"+ it "can navigate down and forwards" $ requireTest $ do+ jsonValueVia (Just cursor) === Right (JsonArray [JsonNull])+ describe "For sample Json" $ do+ let cursor = makeCursor "{ \+ \ \"widget\": { \+ \ \"debug\": \"on\", \+ \ \"window\": { \+ \ \"name\": \"main_window\", \+ \ \"dimensions\": [500, 600.01e-02, true, false, null] \+ \ } \+ \ } \+ \}" :: GenericCursor BS.ByteString t u+ it "can navigate down and forwards" $ requireTest $ do+ let array = JsonArray [JsonNumber 500, JsonNumber 600.01e-02, JsonBool True, JsonBool False, JsonNull] :: JsonValue+ let object1 = JsonObject ([("name", JsonString "main_window"), ("dimensions", array)]) :: JsonValue+ let object2 = JsonObject ([("debug", JsonString "on"), ("window", object1)]) :: JsonValue+ let object3 = JsonObject ([("widget", object2)]) :: JsonValue+ jsonValueVia (Just cursor) === Right object3+ jsonValueVia ((fc ) cursor) === Right (JsonString "widget" )+ jsonValueVia ((fc >=> ns ) cursor) === Right (object2 )+ jsonValueVia ((fc >=> ns >=> fc ) cursor) === Right (JsonString "debug" )+ jsonValueVia ((fc >=> ns >=> fc >=> ns ) cursor) === Right (JsonString "on" )+ jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns ) cursor) === Right (JsonString "window" )+ jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns ) cursor) === Right (object1 )+ jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc ) cursor) === Right (JsonString "name" )+ jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns ) cursor) === Right (JsonString "main_window" )+ jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns ) cursor) === Right (JsonString "dimensions" )+ jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns ) cursor) === Right (array )+ jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc ) cursor) === Right (JsonNumber 500 )+ jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns ) cursor) === Right (JsonNumber 600.01e-02 )+ jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns ) cursor) === Right (JsonBool True )+ jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns ) cursor) === Right (JsonBool False )+ jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> ns) cursor) === Right JsonNull
+ test/HaskellWorks/Data/Json/Simple/CursorSpec.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module HaskellWorks.Data.Json.Simple.CursorSpec+ ( spec+ ) where++import Control.Monad+import HaskellWorks.Data.Json.LightJson+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified HaskellWorks.Data.Json.Simple.Cursor as Z+import qualified HaskellWorks.Data.Json.Simple.Cursor.Fast as FAST+import qualified HaskellWorks.Data.Json.Simple.Value as V+import qualified HaskellWorks.Data.TreeCursor as TC++{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant bracket" -}+{- HLINT ignore "Redundant do" -}++fc = TC.firstChild+ns = TC.nextSibling++spec :: Spec+spec = describe "HaskellWorks.Data.Json.Backend.Simple.CursorSpec" $ do+ describe "Json cursor" $ do+ describe "For sample Json" $ do+ let k = FAST.fromByteString "[[11],[22]]"+ -- [ [ 1 1 ] , [ 2 2 ] ]+ -- (( (( )) )( (( )) ))+ it "can navigate" $ requireTest $ do+ (Z.cursorRank <$> Just k) === Just 1+ (Z.cursorRank <$> ns k) === Nothing+ (Z.cursorRank <$> fc k) === Just 2+ (Z.cursorRank <$> (fc >=> ns ) k) === Just 8+ (Z.cursorRank <$> (fc >=> ns >=> fc ) k) === Just 9+ (Z.cursorRank <$> (fc >=> ns >=> fc >=> ns ) k) === Nothing+ (Z.cursorRank <$> (fc >=> ns >=> fc >=> fc ) k) === Just 10+ (Z.cursorRank <$> (fc >=> ns >=> fc >=> fc >=> ns) k) === Nothing+ (Z.cursorRank <$> (fc >=> ns >=> fc >=> fc >=> fc) k) === Nothing+ (Z.cursorRank <$> (fc >=> fc ) k) === Just 3+ (Z.cursorRank <$> (fc >=> fc >=> ns ) k) === Nothing+ (Z.cursorRank <$> (fc >=> fc >=> fc ) k) === Just 4+ (Z.cursorRank <$> (fc >=> fc >=> fc >=> ns ) k) === Nothing+ (Z.cursorRank <$> (fc >=> fc >=> fc >=> fc ) k) === Nothing+ it "can snippet pos" $ requireTest $ do+ (V.snippetPos <$> Just k) === Just (1, 11)+ (V.snippetPos <$> ns k) === Nothing+ (V.snippetPos <$> fc k) === Just (2, 5)+ (V.snippetPos <$> (fc >=> ns ) k) === Just (7, 10)+ (V.snippetPos <$> (fc >=> ns >=> fc ) k) === Just (7, 10)+ (V.snippetPos <$> (fc >=> ns >=> fc >=> ns ) k) === Nothing+ (V.snippetPos <$> (fc >=> ns >=> fc >=> fc ) k) === Just (8, 9)+ (V.snippetPos <$> (fc >=> ns >=> fc >=> fc >=> ns) k) === Nothing+ (V.snippetPos <$> (fc >=> ns >=> fc >=> fc >=> fc) k) === Nothing+ (V.snippetPos <$> (fc >=> fc ) k) === Just (2, 5)+ (V.snippetPos <$> (fc >=> fc >=> ns ) k) === Nothing+ (V.snippetPos <$> (fc >=> fc >=> fc ) k) === Just (3, 4)+ (V.snippetPos <$> (fc >=> fc >=> fc >=> ns ) k) === Nothing+ (V.snippetPos <$> (fc >=> fc >=> fc >=> fc ) k) === Nothing+ it "can snippet" $ requireTest $ do+ (V.snippet <$> Just k) === Just "[[11],[22]]"+ (V.snippet <$> ns k) === Nothing+ (V.snippet <$> fc k) === Just "[11]"+ (V.snippet <$> (fc >=> ns ) k) === Just "[22]"+ (V.snippet <$> (fc >=> ns >=> fc ) k) === Just "[22]"+ (V.snippet <$> (fc >=> ns >=> fc >=> ns ) k) === Nothing+ (V.snippet <$> (fc >=> ns >=> fc >=> fc ) k) === Just "22"+ (V.snippet <$> (fc >=> ns >=> fc >=> fc >=> ns) k) === Nothing+ (V.snippet <$> (fc >=> ns >=> fc >=> fc >=> fc) k) === Nothing+ (V.snippet <$> (fc >=> fc ) k) === Just "[11]"+ (V.snippet <$> (fc >=> fc >=> ns ) k) === Nothing+ (V.snippet <$> (fc >=> fc >=> fc ) k) === Just "11"+ (V.snippet <$> (fc >=> fc >=> fc >=> ns ) k) === Nothing+ (V.snippet <$> (fc >=> fc >=> fc >=> fc ) k) === Nothing+ it "can lightJsonAt" $ requireTest $ do+ lightJsonAt k === LightJsonArray []
+ test/HaskellWorks/Data/Json/Standard/CursorSpec.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module HaskellWorks.Data.Json.Standard.CursorSpec(spec) where++import HaskellWorks.Data.Json.Standard.GenCursorTest+import Test.Hspec++import qualified HaskellWorks.Data.Json.Standard.Cursor.Fast as FAST+import qualified HaskellWorks.Data.Json.Standard.Cursor.Slow as SLOW++{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant bracket" -}+{- HLINT ignore "Redundant do" -}++spec :: Spec+spec = describe "HaskellWorks.Data.Json.Succinct.CursorSpec" $ do+ genTest "DVS.Vector Word64" SLOW.fromString+ genTest "CsPoppy" FAST.fromString
+ test/HaskellWorks/Data/Json/Standard/GenCursorTest.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module HaskellWorks.Data.Json.Standard.GenCursorTest(genTest) where++import Control.Monad+import HaskellWorks.Data.BalancedParens.BalancedParens+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Json.Internal.Index+import HaskellWorks.Data.Json.Internal.Standard.Cursor.Token+import HaskellWorks.Data.Json.Internal.Token+import HaskellWorks.Data.Json.Standard.Cursor.Generic+import HaskellWorks.Data.RankSelect.Base.Rank0+import HaskellWorks.Data.RankSelect.Base.Rank1+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified Data.ByteString as BS+import qualified HaskellWorks.Data.TreeCursor as TC++{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant bracket" -}+{- HLINT ignore "Redundant do" -}++fc = TC.firstChild+ns = TC.nextSibling+pn = TC.parent+ss = TC.subtreeSize++genTest :: forall t u.+ ( Eq t+ , Show t+ , Select1 t+ , Eq u+ , Show u+ , Rank0 u+ , Rank1 u+ , BalancedParens u+ , TestBit u)+ => String -> (String -> GenericCursor BS.ByteString t u) -> SpecWith ()+genTest t mkCursor = do+ describe ("Json cursor of type " ++ t) $ do+ describe "For empty json array" $ do+ let cursor = mkCursor "[null]"+ it "can navigate down and forwards" $ requireTest $ do+ jsonIndexAt cursor === Right (JsonIndexArray [JsonIndexNull])+ describe "For sample Json" $ do+ let cursor = mkCursor "\+ \{ \+ \ \"widget\": { \+ \ \"debug\": \"on\", \+ \ \"window\": { \+ \ \"name\": \"main_window\", \+ \ \"dimensions\": [500, 600.01e-02, true, false, null] \+ \ } \+ \ } \+ \}"+ it "can navigate up" $ requireTest $ do+ ( pn) cursor === Nothing+ (fc >=> pn) cursor === Just cursor+ (fc >=> ns >=> pn) cursor === Just cursor+ (fc >=> ns >=> fc >=> pn) cursor === (fc >=> ns ) cursor+ (fc >=> ns >=> fc >=> ns >=> pn) cursor === (fc >=> ns ) cursor+ (fc >=> ns >=> fc >=> ns >=> ns >=> pn) cursor === (fc >=> ns ) cursor+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor === (fc >=> ns ) cursor+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor+ it "can get subtree size" $ requireTest $ do+ ( ss) cursor === Just 16+ (fc >=> ss) cursor === Just 1+ (fc >=> ns >=> ss) cursor === Just 14+ (fc >=> ns >=> fc >=> ss) cursor === Just 1+ (fc >=> ns >=> fc >=> ns >=> ss) cursor === Just 1+ (fc >=> ns >=> fc >=> ns >=> ns >=> ss) cursor === Just 1+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> ss) cursor === Just 10+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ss) cursor === Just 1+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ss) cursor === Just 1+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ss) cursor === Just 1+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> ss) cursor === Just 6+ it "can get token at cursor" $ requireTest $ do+ (jsonTokenAt ) cursor === Just (JsonTokenBraceL )+ (fc >=> jsonTokenAt) cursor === Just (JsonTokenString "widget" )+ (fc >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenBraceL )+ (fc >=> ns >=> fc >=> jsonTokenAt) cursor === Just (JsonTokenString "debug" )+ (fc >=> ns >=> fc >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenString "on" )+ (fc >=> ns >=> fc >=> ns >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenString "window" )+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenBraceL )+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> jsonTokenAt) cursor === Just (JsonTokenString "name" )+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenString "main_window" )+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenString "dimensions" )+ (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> jsonTokenAt) cursor === Just (JsonTokenBracketL )
− test/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParensSpec.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}--module HaskellWorks.Data.Json.Succinct.Cursor.BalancedParensSpec(spec) where--import Data.String-import HaskellWorks.Data.Bits.BitShown-import HaskellWorks.Data.Json.Internal.Backend.Standard.MakeIndex-import HaskellWorks.Hspec.Hedgehog-import Hedgehog-import Test.Hspec--import qualified Data.ByteString as BS-import qualified HaskellWorks.Data.Json.Internal.Backend.Standard.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" $ requireTest $ do- let blankedJson = J.BlankedJson ["[ [],", "[]]"]- let bp = BitShown $ BS.concat (blankedJsonToBalancedParens (J.unBlankedJson blankedJson))- bp === fromString "11111111 11111111 00000000 11111111 00000000 00000000"- it "Blanking JSON should not contain strange characters 2" $ requireTest $ do- let blankedJson = J.BlankedJson ["[ [],", "[]]"]- let bp = BitShown $ BS.concat ((compressWordAsBit . blankedJsonToBalancedParens) (J.unBlankedJson blankedJson))- bp === fromString "11010000"
test/HaskellWorks/Data/Json/Token/TokenizeSpec.hs view
@@ -2,15 +2,15 @@ module HaskellWorks.Data.Json.Token.TokenizeSpec (spec) where -import Data.ByteString (ByteString)-import HaskellWorks.Data.Json.Internal.Backend.Standard.Token.Tokenize+import Data.ByteString (ByteString)+import HaskellWorks.Data.Json.Internal.Standard.Token.Tokenize import HaskellWorks.Hspec.Hedgehog import Hedgehog import Test.Hspec import qualified Data.Attoparsec.ByteString.Char8 as BC -{-# ANN module ("HLint: ignore Redundant do" :: String) #-}+{- HLINT ignore "Redundant do" -} parseJsonToken' :: ByteString -> Either String (JsonToken String Double) parseJsonToken' = BC.parseOnly parseJsonToken
test/HaskellWorks/Data/Json/TypeSpec.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-}@@ -14,8 +12,8 @@ import Control.Monad import HaskellWorks.Data.BalancedParens.BalancedParens import HaskellWorks.Data.Bits.BitWise-import HaskellWorks.Data.Json.Backend.Standard.Cursor-import HaskellWorks.Data.Json.Type+import HaskellWorks.Data.Json.Standard.Cursor.Generic+import HaskellWorks.Data.Json.Standard.Cursor.Type import HaskellWorks.Data.RankSelect.Base.Rank0 import HaskellWorks.Data.RankSelect.Base.Rank1 import HaskellWorks.Data.RankSelect.Base.Select1@@ -23,34 +21,30 @@ import Hedgehog import Test.Hspec -import qualified Data.ByteString as BS-import qualified HaskellWorks.Data.Json.Backend.Standard.Fast as FAST-import qualified HaskellWorks.Data.Json.Backend.Standard.Slow as SLOW-import qualified HaskellWorks.Data.TreeCursor as TC+import qualified Data.ByteString as BS+import qualified HaskellWorks.Data.Json.Standard.Cursor.Fast as FAST+import qualified HaskellWorks.Data.Json.Standard.Cursor.Slow as SLOW+import qualified HaskellWorks.Data.TreeCursor as TC -{-# ANN module ("HLint: ignore Redundant do" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}-{-# ANN module ("HLint: redundant bracket" :: String) #-}+{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant bracket" -}+{- HLINT ignore "Redundant do" -} fc = TC.firstChild ns = TC.nextSibling spec :: Spec spec = describe "HaskellWorks.Data.Json.Succinct.CursorSpec" $ do- genSpec "DVS.Vector Word64" SLOW.makeCursor- genSpec "Poppy512" FAST.makeCursor+ genSpec "DVS.Vector Word64" SLOW.fromString+ genSpec "CsPoppy" FAST.fromString genSpec :: forall t u.- ( Eq t- , Show t- , Select1 t- , Eq u- , Show u+ ( Select1 t , Rank0 u , Rank1 u , BalancedParens u , TestBit u)- => String -> (String -> JsonCursor BS.ByteString t u) -> SpecWith ()+ => String -> (String -> GenericCursor BS.ByteString t u) -> SpecWith () genSpec t makeCursor = do describe ("Json cursor of type " ++ t) $ do let forJson s f = describe ("of value " ++ show s) (f (makeCursor s))@@ -95,7 +89,7 @@ \ \"dimensions\": [500, 600.01e-02, true, false, null] \ \ } \ \ } \- \}" :: JsonCursor BS.ByteString t u+ \}" :: GenericCursor BS.ByteString t u it "can navigate down and forwards" $ requireTest $ do ( jsonTypeAt) cursor === Just JsonTypeObject (fc >=> jsonTypeAt) cursor === Just JsonTypeString
test/HaskellWorks/Data/Json/ValueSpec.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-}@@ -14,9 +12,9 @@ import Control.Monad import HaskellWorks.Data.BalancedParens.BalancedParens import HaskellWorks.Data.Bits.BitWise-import HaskellWorks.Data.Json.Backend.Standard.Cursor import HaskellWorks.Data.Json.DecodeError import HaskellWorks.Data.Json.Internal.Index+import HaskellWorks.Data.Json.Standard.Cursor.Generic import HaskellWorks.Data.Json.Value import HaskellWorks.Data.RankSelect.Base.Rank0 import HaskellWorks.Data.RankSelect.Base.Rank1@@ -25,22 +23,22 @@ import Hedgehog import Test.Hspec -import qualified Data.ByteString as BS-import qualified HaskellWorks.Data.Json.Backend.Standard.Fast as FAST-import qualified HaskellWorks.Data.Json.Backend.Standard.Slow as SLOW-import qualified HaskellWorks.Data.TreeCursor as TC+import qualified Data.ByteString as BS+import qualified HaskellWorks.Data.Json.Standard.Cursor.Fast as FAST+import qualified HaskellWorks.Data.Json.Standard.Cursor.Slow as SLOW+import qualified HaskellWorks.Data.TreeCursor as TC -{-# ANN module ("HLint: ignore Redundant do" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}-{-# ANN module ("HLint: redundant bracket" :: String) #-}+{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant bracket" -}+{- HLINT ignore "Redundant do" -} fc = TC.firstChild ns = TC.nextSibling spec :: Spec spec = describe "HaskellWorks.Data.Json.ValueSpec" $ do- genSpec "DVS.Vector Word64" SLOW.makeCursor- genSpec "Poppy512" FAST.makeCursor+ genSpec "DVS.Vector Word64" SLOW.fromString+ genSpec "CsPoppy" FAST.fromString jsonValueVia :: ( BalancedParens u@@ -48,22 +46,18 @@ , Rank1 u , Select1 t , TestBit u)- => Maybe (JsonCursor BS.ByteString t u) -> Either DecodeError JsonValue+ => Maybe (GenericCursor BS.ByteString t u) -> Either DecodeError JsonValue jsonValueVia mk = case mk of Just k -> (jsonIndexAt >=> jsonValueAt) k Nothing -> Left (DecodeError "No such element") genSpec :: forall t u.- ( Eq t- , Show t- , Select1 t- , Eq u- , Show u+ ( Select1 t , Rank0 u , Rank1 u , BalancedParens u , TestBit u)- => String -> (String -> JsonCursor BS.ByteString t u) -> SpecWith ()+ => String -> (String -> GenericCursor BS.ByteString t u) -> SpecWith () genSpec t makeCursor = do describe ("Json cursor of type " ++ t) $ do let forJson s f = describe ("of value " ++ show s) (f (makeCursor s))@@ -86,6 +80,9 @@ forJson "[null]" $ \cursor -> do it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonArray [JsonNull]) it "should have correct value" $ requireTest $ jsonValueVia (fc cursor) === Right JsonNull+ it "should have correct value" $ requireTest $ jsonValueVia (fc cursor) === Right JsonNull+ forJson "\"codepoint\\u2019s\"" $ \cursor -> do+ it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonString "codepoint’s") forJson "[null, {\"field\": 1}]" $ \cursor -> do it "cursor can navigate to second child of array" $ requireTest $ do jsonValueVia ((fc >=> ns) cursor) === Right ( JsonObject [("field", JsonNumber 1)] )@@ -107,7 +104,7 @@ \ \"dimensions\": [500, 600.01e-02, true, false, null] \ \ } \ \ } \- \}" :: JsonCursor BS.ByteString t u+ \}" :: GenericCursor BS.ByteString t u it "can navigate down and forwards" $ requireTest $ do let array = JsonArray [JsonNumber 500, JsonNumber 600.01e-02, JsonBool True, JsonBool False, JsonNull] :: JsonValue let object1 = JsonObject ([("name", JsonString "main_window"), ("dimensions", array)]) :: JsonValue