|
| 1 | +{-# LANGUAGE ExplicitForAll #-} |
| 2 | +{-# LANGUAGE FlexibleContexts #-} |
| 3 | +{-# LANGUAGE FlexibleInstances #-} |
| 4 | +{-# LANGUAGE InstanceSigs #-} |
| 5 | +{-# LANGUAGE MultiParamTypeClasses #-} |
| 6 | +{-# LANGUAGE NoMonomorphismRestriction #-} |
| 7 | +{-# LANGUAGE OverloadedStrings #-} |
| 8 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 9 | +{-# LANGUAGE TupleSections #-} |
| 10 | + |
| 11 | +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} |
| 12 | + |
| 13 | +module HaskellWorks.Data.Json.LightJsonSpec (spec) where |
| 14 | + |
| 15 | +import Control.Monad |
| 16 | +import Data.Text |
| 17 | +import HaskellWorks.Data.BalancedParens.BalancedParens |
| 18 | +import HaskellWorks.Data.Bits.BitWise |
| 19 | +import HaskellWorks.Data.Json.DecodeError |
| 20 | +import HaskellWorks.Data.Json.LightJson |
| 21 | +import HaskellWorks.Data.Json.Standard.Cursor.Generic |
| 22 | +import HaskellWorks.Data.Json.Value |
| 23 | +import HaskellWorks.Data.RankSelect.Base.Rank0 |
| 24 | +import HaskellWorks.Data.RankSelect.Base.Rank1 |
| 25 | +import HaskellWorks.Data.RankSelect.Base.Select1 |
| 26 | +import HaskellWorks.Hspec.Hedgehog |
| 27 | +import Hedgehog |
| 28 | +import Test.Hspec |
| 29 | + |
| 30 | +import qualified Data.Aeson.Parser.Internal as AP |
| 31 | +import qualified Data.Attoparsec.ByteString as PBS |
| 32 | +import qualified Data.ByteString as BS |
| 33 | +import qualified Data.Scientific as S |
| 34 | +import qualified Data.Text as T |
| 35 | +import qualified HaskellWorks.Data.Json.Standard.Cursor.Fast as FAST |
| 36 | +import qualified HaskellWorks.Data.Json.Standard.Cursor.Slow as SLOW |
| 37 | +import qualified HaskellWorks.Data.TreeCursor as TC |
| 38 | + |
| 39 | +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} |
| 40 | +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} |
| 41 | +{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} |
| 42 | + |
| 43 | +fc = TC.firstChild |
| 44 | +ns = TC.nextSibling |
| 45 | + |
| 46 | +spec :: Spec |
| 47 | +spec = describe "HaskellWorks.Data.Json.LightJsonSpec" $ do |
| 48 | + genSpec "DVS.Vector Word64" SLOW.fromString |
| 49 | + genSpec "CsPoppy" FAST.fromString |
| 50 | + |
| 51 | +jsonValueVia :: forall t u. |
| 52 | + ( BalancedParens u |
| 53 | + , Rank0 u |
| 54 | + , Rank1 u |
| 55 | + , Select1 t |
| 56 | + , TestBit u) |
| 57 | + => Maybe (GenericCursor BS.ByteString t u) |
| 58 | + -> Either DecodeError JsonValue |
| 59 | +jsonValueVia mk = case mk of |
| 60 | + Just k -> case lightJsonAt k of |
| 61 | + LightJsonString t -> Right (JsonString t) |
| 62 | + LightJsonNumber bs -> case PBS.parseOnly AP.scientific bs of |
| 63 | + Right s -> Right (JsonNumber (S.toRealFloat s)) |
| 64 | + Left msg -> Left (DecodeError msg) |
| 65 | + LightJsonObject ps -> fmap JsonObject (traverse fields ps) |
| 66 | + LightJsonArray cs -> fmap JsonArray (traverse elements cs) |
| 67 | + LightJsonBool v -> Right (JsonBool v) |
| 68 | + LightJsonNull -> Right JsonNull |
| 69 | + LightJsonError msg -> Left (DecodeError (T.unpack msg)) |
| 70 | + Nothing -> Left (DecodeError "No such element") |
| 71 | + where fields :: (Text, GenericCursor BS.ByteString t u) -> Either DecodeError (Text, JsonValue) |
| 72 | + fields (f, c) = (f,) <$> jsonValueVia (Just c) |
| 73 | + elements :: GenericCursor BS.ByteString t u -> Either DecodeError JsonValue |
| 74 | + elements c = jsonValueVia (Just c) |
| 75 | + |
| 76 | +genSpec :: forall t u. |
| 77 | + ( Eq t |
| 78 | + , Show t |
| 79 | + , Select1 t |
| 80 | + , Eq u |
| 81 | + , Show u |
| 82 | + , Rank0 u |
| 83 | + , Rank1 u |
| 84 | + , BalancedParens u |
| 85 | + , TestBit u) |
| 86 | + => String -> (String -> GenericCursor BS.ByteString t u) -> SpecWith () |
| 87 | +genSpec t makeCursor = do |
| 88 | + describe ("Json cursor of type " ++ t) $ do |
| 89 | + let forJson s f = describe ("of value " ++ show s) (f (makeCursor s)) |
| 90 | + forJson "{}" $ \cursor -> do |
| 91 | + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonObject []) |
| 92 | + forJson " {}" $ \cursor -> do |
| 93 | + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonObject []) |
| 94 | + forJson "1234" $ \cursor -> do |
| 95 | + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonNumber 1234) |
| 96 | + forJson "\"Hello\"" $ \cursor -> do |
| 97 | + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonString "Hello") |
| 98 | + forJson "[]" $ \cursor -> do |
| 99 | + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonArray []) |
| 100 | + forJson "true" $ \cursor -> do |
| 101 | + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonBool True) |
| 102 | + forJson "false" $ \cursor -> do |
| 103 | + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonBool False) |
| 104 | + forJson "null" $ \cursor -> do |
| 105 | + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right JsonNull |
| 106 | + forJson "[null]" $ \cursor -> do |
| 107 | + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonArray [JsonNull]) |
| 108 | + it "should have correct value" $ requireTest $ jsonValueVia (fc cursor) === Right JsonNull |
| 109 | + forJson "[null, {\"field\": 1}]" $ \cursor -> do |
| 110 | + it "cursor can navigate to second child of array" $ requireTest $ do |
| 111 | + jsonValueVia ((fc >=> ns) cursor) === Right ( JsonObject [("field", JsonNumber 1)] ) |
| 112 | + jsonValueVia (Just cursor) === Right (JsonArray [JsonNull, JsonObject [("field", JsonNumber 1)]]) |
| 113 | + describe "For empty json array" $ do |
| 114 | + let cursor = makeCursor "[]" |
| 115 | + it "can navigate down and forwards" $ requireTest $ do |
| 116 | + jsonValueVia (Just cursor) === Right (JsonArray []) |
| 117 | + describe "For empty json array" $ do |
| 118 | + let cursor = makeCursor "[null]" |
| 119 | + it "can navigate down and forwards" $ requireTest $ do |
| 120 | + jsonValueVia (Just cursor) === Right (JsonArray [JsonNull]) |
| 121 | + describe "For sample Json" $ do |
| 122 | + let cursor = makeCursor "{ \ |
| 123 | + \ \"widget\": { \ |
| 124 | + \ \"debug\": \"on\", \ |
| 125 | + \ \"window\": { \ |
| 126 | + \ \"name\": \"main_window\", \ |
| 127 | + \ \"dimensions\": [500, 600.01e-02, true, false, null] \ |
| 128 | + \ } \ |
| 129 | + \ } \ |
| 130 | + \}" :: GenericCursor BS.ByteString t u |
| 131 | + it "can navigate down and forwards" $ requireTest $ do |
| 132 | + let array = JsonArray [JsonNumber 500, JsonNumber 600.01e-02, JsonBool True, JsonBool False, JsonNull] :: JsonValue |
| 133 | + let object1 = JsonObject ([("name", JsonString "main_window"), ("dimensions", array)]) :: JsonValue |
| 134 | + let object2 = JsonObject ([("debug", JsonString "on"), ("window", object1)]) :: JsonValue |
| 135 | + let object3 = JsonObject ([("widget", object2)]) :: JsonValue |
| 136 | + jsonValueVia (Just cursor) === Right object3 |
| 137 | + jsonValueVia ((fc ) cursor) === Right (JsonString "widget" ) |
| 138 | + jsonValueVia ((fc >=> ns ) cursor) === Right (object2 ) |
| 139 | + jsonValueVia ((fc >=> ns >=> fc ) cursor) === Right (JsonString "debug" ) |
| 140 | + jsonValueVia ((fc >=> ns >=> fc >=> ns ) cursor) === Right (JsonString "on" ) |
| 141 | + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns ) cursor) === Right (JsonString "window" ) |
| 142 | + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns ) cursor) === Right (object1 ) |
| 143 | + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc ) cursor) === Right (JsonString "name" ) |
| 144 | + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns ) cursor) === Right (JsonString "main_window" ) |
| 145 | + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns ) cursor) === Right (JsonString "dimensions" ) |
| 146 | + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns ) cursor) === Right (array ) |
| 147 | + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc ) cursor) === Right (JsonNumber 500 ) |
| 148 | + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns ) cursor) === Right (JsonNumber 600.01e-02 ) |
| 149 | + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns ) cursor) === Right (JsonBool True ) |
| 150 | + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns ) cursor) === Right (JsonBool False ) |
| 151 | + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> ns) cursor) === Right JsonNull |
0 commit comments