Delegate to aesons string parser

hw-json.cabal

@@ -39,6 +39,7 @@ flag sse42
 
 common base                     { build-depends: base                     >= 4          && < 5      }
 
+common aeson                    { build-depends: aeson                    >= 1.4.3.0    && < 1.5    }
 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   }
@@ -65,6 +66,7 @@ common hw-simd                  { build-depends: hw-simd                  >= 0.1
 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 scientific               { build-depends: scientific               >= 0.3.6.2    && < 0.4    }
 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   }
@@ -83,6 +85,7 @@ common config
 
 library
   import:   base, config
+          , aeson
           , ansi-wl-pprint
           , attoparsec
           , bits-extra
@@ -160,6 +163,7 @@ executable hw-json
 
 test-suite hw-json-test
   import:   base, config
+          , aeson
           , attoparsec
           , bytestring
           , hedgehog
@@ -172,6 +176,8 @@ test-suite hw-json-test
           , hw-prim
           , hw-rankselect
           , hw-rankselect-base
+          , scientific
+          , text
           , transformers
           , vector
   type:               exitcode-stdio-1.0
@@ -181,6 +187,7 @@ test-suite hw-json-test
   ghc-options:        -threaded -rtsopts -with-rtsopts=-N
   build-tools:        hspec-discover
   other-modules:
+      HaskellWorks.Data.Json.LightJsonSpec
       HaskellWorks.Data.Json.Simple.CursorSpec
       HaskellWorks.Data.Json.Standard.CursorSpec
       HaskellWorks.Data.Json.Standard.GenCursorTest

src/HaskellWorks/Data/Json/Internal/Slurp.hs

@@ -13,10 +13,12 @@ import Data.Word8
 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.Text             as T
+import qualified Data.Aeson.Parser.Internal as AP
+import qualified Data.Attoparsec.ByteString as PBS
+import qualified Data.ByteString            as BS
+import qualified Data.ByteString.Char8      as BSC
+import qualified Data.List                  as L
+import qualified Data.Text                  as T
 
 data JsonState
   = Escaped
@@ -25,22 +27,10 @@ data JsonState
   | InNumber
   | InIdent
 
-slurpText :: BS.ByteString -> Text
-slurpText bs = T.pack $ L.unfoldr genString (InJson, BSC.unpack bs) -- TODO optimise
-  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
+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)
 
 slurpNumber :: BS.ByteString -> BS.ByteString
 slurpNumber bs = let (!cs, _) = BS.unfoldrN (BS.length bs) genNumber (InJson, bs) in cs

src/HaskellWorks/Data/Json/LightJson.hs

@@ -31,7 +31,6 @@ import HaskellWorks.Data.RankSelect.Base.Select1
 import HaskellWorks.Data.TreeCursor
 import HaskellWorks.Data.Uncons
 import Prelude                                        hiding (drop)
-import Prelude                                        hiding (drop)
 import Text.PrettyPrint.ANSI.Leijen
 
 import qualified Data.ByteString                  as BS
@@ -126,7 +125,7 @@ instance LightJsonAt c => Pretty (MQuery (Entry String (LightJson c))) where
 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       -> LightJsonString  (slurpText   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

test/HaskellWorks/Data/Json/LightJsonSpec.hs

@@ -0,0 +1,151 @@
+{-# LANGUAGE ExplicitForAll            #-}
+{-# LANGUAGE FlexibleContexts          #-}
+{-# LANGUAGE FlexibleInstances         #-}
+{-# LANGUAGE InstanceSigs              #-}
+{-# LANGUAGE MultiParamTypeClasses     #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE ScopedTypeVariables       #-}
+{-# LANGUAGE TupleSections             #-}
+
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+
+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
+
+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}
+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}
+{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}
+
+fc = TC.firstChild
+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.
+  ( 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 ()
+genSpec t makeCursor = do
+  describe ("Json cursor of type " ++ t) $ do
+    let forJson s f = describe ("of value " ++ 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 "[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