Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Commit 101949f

Browse files
cocreaturecocreature
committed
Merge pull request #167 from glittershark/better-json-error-messages
Improve error messages in JSON parsing
2 parents 190c81f + 9332f68 commit 101949f

File tree

2 files changed

+38
-47
lines changed

2 files changed

+38
-47
lines changed

‎hie-base/Haskell/Ide/Engine/PluginTypes.hs

+16-23
Original file line numberDiff line numberDiff line change
@@ -366,14 +366,13 @@ instance (ValidResponse a) => ToJSON (IdeResponse a) where
366366
toJSON (IdeResponseError v) = object [ "error" .= v ]
367367

368368
instance (ValidResponse a) => FromJSON (IdeResponse a) where
369-
parseJSON (Object v) = do
369+
parseJSON = withObject "IdeResponse" $ \v -> do
370370
mf <- fmap IdeResponseFail <$> v .:? "fail"
371371
me <- fmap IdeResponseError <$> v .:? "error"
372372
let mo = IdeResponseOk <$> parseMaybe jsRead v
373373
case (mf <|> me <|> mo) of
374374
Just r -> return r
375375
Nothing -> empty
376-
parseJSON _ = empty
377376

378377

379378
instance ToJSON ParamValP where
@@ -383,23 +382,22 @@ instance ToJSON ParamValP where
383382
toJSON _ = "error"
384383

385384
instance FromJSON (ParamVal 'PtText) where
386-
parseJSON (Object v) = ParamText <$> v .: "text"
387-
parseJSON _ = empty
385+
parseJSON = withObject "text parameter object" $ \v ->
386+
ParamText <$> v .: "text"
388387

389388
instance FromJSON (ParamVal 'PtFile) where
390-
parseJSON (Object v) = ParamFile <$> v.: "file"
391-
parseJSON _ = empty
389+
parseJSON = withObject "file parameter object" $ \v -> ParamFile <$> v.: "file"
392390

393391
instance FromJSON (ParamVal 'PtPos) where
394-
parseJSON (Object v) = fmap ParamPos $ liftA2 (,) (v .: "line") (v .: "col")
395-
parseJSON _ = empty
392+
parseJSON = withObject "position parameter object" $ \v ->
393+
fmap ParamPos $ liftA2 (,) (v .: "line") (v .: "col")
396394

397395
instance FromJSON ParamValP where
398396
parseJSON val = do
399397
let mt = ParamValP <$> (parseJSON val :: Parser (ParamVal 'PtText))
400398
mf = ParamValP <$> (parseJSON val :: Parser (ParamVal 'PtFile))
401399
mp = ParamValP <$> (parseJSON val :: Parser (ParamVal 'PtPos))
402-
mt <|> mf <|> mp
400+
mf <|> mp <|> mt <|> typeMismatch "text, file, or position object" val
403401

404402
-- -------------------------------------
405403

@@ -409,21 +407,20 @@ instance ToJSON IdeRequest where
409407
, "params" .= params]
410408

411409
instance FromJSON IdeRequest where
412-
parseJSON (Object v) =
410+
parseJSON = withObject "IdeRequest" $ \v ->
413411
IdeRequest <$> v .: "cmd"
414412
<*> v .: "params"
415-
parseJSON _ = empty
416413

417414
-- -------------------------------------
418415

419416
instance ToJSON IdeErrorCode where
420417
toJSON code = String $ T.pack $ show code
421418

422419
instance FromJSON IdeErrorCode where
423-
parseJSON (String s) = case reads (T.unpack s) of
424-
((c,""):_) -> pure c
425-
_ -> empty
426-
parseJSON _ = empty
420+
parseJSON = withText "IdeErrorCode" $ \s ->
421+
case reads (T.unpack s) of
422+
((c,""):_) -> pure c
423+
_ -> empty
427424

428425
-- -------------------------------------
429426

@@ -433,11 +430,10 @@ instance ToJSON IdeError where
433430
, "info" .= ideInfo err]
434431

435432
instance FromJSON IdeError where
436-
parseJSON (Object v) = IdeError
433+
parseJSON = withObject "IdeError" $ \v -> IdeError
437434
<$> v .: "code"
438435
<*> v .: "msg"
439436
<*> v .: "info"
440-
parseJSON _ = empty
441437

442438

443439

@@ -447,8 +443,7 @@ instance ToJSON CabalSection where
447443
toJSON (CabalSection s) = toJSON s
448444

449445
instance FromJSON CabalSection where
450-
parseJSON (String s) = pure $ CabalSection s
451-
parseJSON _ = empty
446+
parseJSON = withText "CabalSection" $ pure . CabalSection
452447

453448
-- -------------------------------------
454449

@@ -457,18 +452,16 @@ instance ToJSON ParamDescription where
457452
object ["name" .= n,"help" .= h,"type" .= t,"required" .= (r == Required)]
458453

459454
instance FromJSON ParamDescription where
460-
parseJSON (Object v) = do
455+
parseJSON = withObject "ParamDescription" $ \v -> do
461456
req <- v .: "required"
462457
if req
463458
then ParamDesc <$> v .: "name" <*> v .: "help" <*> v .: "type" <*> pure Required
464459
else ParamDesc <$> v .: "name" <*> v .: "help" <*> v .: "type" <*> pure Optional
465-
parseJSON _ = empty
466460

467461
-- -------------------------------------
468462

469463
instance ToJSON UntaggedCommandDescriptor where
470464
toJSON = Object . jsWrite
471465

472466
instance FromJSON UntaggedCommandDescriptor where
473-
parseJSON (Object v) = jsRead v
474-
parseJSON _ = empty
467+
parseJSON = withObject "UntaggedCommandDescriptor" jsRead

‎src/Haskell/Ide/Engine/Transport/JsonStdio.hs

+22-24
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,6 @@ import Data.Aeson
1313
import Control.Monad.IO.Class
1414
import Control.Monad.STM
1515
import Control.Monad.State.Strict
16-
import qualified Data.Aeson as A
1716
import qualified Data.Attoparsec.ByteString as AB
1817
import qualified Data.Attoparsec.ByteString.Char8 as AB
1918
import qualified Data.ByteString.Char8 as B
@@ -63,10 +62,10 @@ parseToJsonPipe oneShot cin cout cid =
6362
cout
6463
(cid + 1)
6564

66-
jsonConsumer :: P.Consumer A.Value IO ()
65+
jsonConsumer :: P.Consumer Value IO ()
6766
jsonConsumer =
6867
do val <- P.await
69-
liftIO $ BL.putStr (A.encode val)
68+
liftIO $ BL.putStr (encode val)
7069
liftIO $ BL.putStr (BL.singleton $ fromIntegral (ord '\STX'))
7170
jsonConsumer
7271

@@ -76,8 +75,8 @@ tchanProducer oneShot chan = do
7675
P.yield val
7776
unless oneShot $ tchanProducer False chan
7877

79-
encodePipe :: P.Pipe ChannelResponse A.Value IO ()
80-
encodePipe = P.map (A.toJSON . channelToWire)
78+
encodePipe :: P.Pipe ChannelResponse Value IO ()
79+
encodePipe = P.map (toJSON . channelToWire)
8180

8281
parseFrames
8382
:: forall m.
@@ -90,8 +89,8 @@ parseFrames prod0 = do
9089
if isEmpty then return () else go prod1
9190
where
9291
-- ignore inputs consisting only of space
93-
terminatedJSON :: AB.Parser (Maybe A.Value)
94-
terminatedJSON = (fmap Just $ A.json' <* AB.many' AB.space <* AB.endOfInput)
92+
terminatedJSON :: AB.Parser (Maybe Value)
93+
terminatedJSON = (fmap Just $ json' <* AB.many' AB.space <* AB.endOfInput)
9594
<|> (AB.many' AB.space *> pure Nothing)
9695
-- endOfInput: we want to be sure that the given
9796
-- parser consumes the entirety of the given input
@@ -107,9 +106,9 @@ parseFrames prod0 = do
107106
let maybeWrappedRet :: Maybe (Either PAe.DecodingError WireRequest)
108107
maybeWrappedRet = case ret of
109108
Left parseErr -> pure $ Left $ PAe.AttoparsecError parseErr
110-
Right (Just a) -> case A.fromJSON a of
111-
A.Error err -> pure $ Left $ PAe.FromJSONError err
112-
A.Success wireReq -> pure $ Right wireReq
109+
Right (Just a) -> case fromJSON a of
110+
Error err -> pure $ Left $ PAe.FromJSONError err
111+
Success wireReq -> pure $ Right wireReq
113112
Right Nothing -> Nothing
114113
case maybeWrappedRet of
115114
Just wrappedRet -> P.yield wrappedRet
@@ -143,7 +142,7 @@ wireToChannel cout ri wr =
143142
-- ---------------------------------------------------------------------
144143

145144
channelToWire :: ChannelResponse -> WireResponse
146-
channelToWire cr = WireResp $ A.toJSON $ coutResp cr
145+
channelToWire cr = WireResp $ toJSON $ coutResp cr
147146

148147
-- ---------------------------------------------------------------------
149148

@@ -152,28 +151,27 @@ data WireRequest = WireReq
152151
, params :: ParamMap
153152
} deriving (Show,Eq)
154153

155-
instance A.ToJSON WireRequest where
156-
toJSON wr = A.object
157-
[ "cmd" A..= cmd wr
158-
, "params" A..= params wr
154+
instance ToJSON WireRequest where
155+
toJSON wr = object
156+
[ "cmd" .= cmd wr
157+
, "params" .= params wr
159158
]
160159

161160

162-
instance A.FromJSON WireRequest where
163-
parseJSON (A.Object v) = WireReq <$>
164-
v A..: "cmd" <*>
165-
v A..:? "params" A..!= Map.empty
166-
-- A non-Object value is of the wrong type, so fail.
167-
parseJSON _ = mzero
161+
instance FromJSON WireRequest where
162+
parseJSON = withObject "WireRequest" $ \v ->
163+
WireReq <$>
164+
v .: "cmd" <*>
165+
v .:? "params" .!= Map.empty
168166

169167
-- ---------------------------------------------------------------------
170168

171-
data WireResponse = WireResp A.Value
169+
data WireResponse = WireResp Value
172170
deriving (Show,Eq)
173171

174-
instance A.ToJSON WireResponse where
172+
instance ToJSON WireResponse where
175173
toJSON (WireResp val) = val
176174

177175

178-
instance A.FromJSON WireResponse where
176+
instance FromJSON WireResponse where
179177
parseJSON p = return $ WireResp p

0 commit comments

Comments
 (0)