Improve error messages in JSON parsing

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

@@ -366,14 +366,13 @@ instance (ValidResponse a) => ToJSON (IdeResponse a) where
  toJSON (IdeResponseError v) = object [ "error" .= v ]
 
 instance (ValidResponse a) => FromJSON (IdeResponse a) where
- parseJSON (Object v) = do
+ parseJSON = withObject "IdeResponse" $ \v -> do
    mf <- fmap IdeResponseFail <$> v .:? "fail"
    me <- fmap IdeResponseError <$> v .:? "error"
    let mo = IdeResponseOk <$> parseMaybe jsRead v
    case (mf <|> me <|> mo) of
      Just r -> return r
      Nothing -> empty
- parseJSON _ = empty
 
 
 instance ToJSON ParamValP  where
@@ -383,23 +382,22 @@ instance ToJSON ParamValP  where
  toJSON _ = "error"
 
 instance FromJSON (ParamVal 'PtText) where
-  parseJSON (Object v) = ParamText <$> v .: "text"
-  parseJSON _ = empty
+  parseJSON = withObject "text parameter object" $ \v ->
+    ParamText <$> v .: "text"
 
 instance FromJSON (ParamVal 'PtFile) where
-  parseJSON (Object v) = ParamFile <$> v.: "file"
-  parseJSON _ = empty
+  parseJSON = withObject "file parameter object" $ \v -> ParamFile <$> v.: "file"
 
 instance FromJSON (ParamVal 'PtPos) where
-  parseJSON (Object v) = fmap ParamPos $ liftA2 (,) (v .: "line") (v .: "col")
-  parseJSON _ = empty
+  parseJSON = withObject "position parameter object" $ \v ->
+    fmap ParamPos $ liftA2 (,) (v .: "line") (v .: "col")
 
 instance FromJSON ParamValP where
  parseJSON val = do
    let mt = ParamValP <$> (parseJSON val :: Parser (ParamVal 'PtText))
        mf = ParamValP <$> (parseJSON val :: Parser (ParamVal 'PtFile))
        mp = ParamValP <$> (parseJSON val :: Parser (ParamVal 'PtPos))
-   mt <|> mf <|> mp
+   mf <|> mp <|> mt <|> typeMismatch "text, file, or position object" val
 
 -- -------------------------------------
 
@@ -409,21 +407,20 @@ instance ToJSON IdeRequest where
           , "params" .= params]
 
 instance FromJSON IdeRequest where
- parseJSON (Object v) =
+ parseJSON = withObject "IdeRequest" $ \v ->
    IdeRequest <$> v .: "cmd"
               <*> v .: "params"
- parseJSON _ = empty
 
 -- -------------------------------------
 
 instance ToJSON IdeErrorCode where
  toJSON code = String $ T.pack $ show code
 
 instance FromJSON IdeErrorCode where
- parseJSON (String s) = case reads (T.unpack s) of
-   ((c,""):_) -> pure c
-   _          -> empty
- parseJSON _ = empty
+ parseJSON = withText "IdeErrorCode" $ \s ->
+   case reads (T.unpack s) of
+     ((c,""):_) -> pure c
+     _          -> empty
 
 -- -------------------------------------
 
@@ -433,11 +430,10 @@ instance ToJSON IdeError where
                      , "info" .= ideInfo err]
 
 instance FromJSON IdeError where
- parseJSON (Object v) = IdeError
+ parseJSON = withObject "IdeError" $ \v -> IdeError
    <$> v .:  "code"
    <*> v .:  "msg"
    <*> v .:  "info"
- parseJSON _ = empty
 
 
 
@@ -447,8 +443,7 @@ instance ToJSON CabalSection where
   toJSON (CabalSection s) = toJSON s
 
 instance FromJSON CabalSection where
-  parseJSON (String s) = pure $ CabalSection s
-  parseJSON _ = empty
+  parseJSON = withText "CabalSection" $ pure . CabalSection
 
 -- -------------------------------------
 
@@ -457,18 +452,16 @@ instance ToJSON ParamDescription where
     object ["name" .= n,"help" .= h,"type" .= t,"required" .= (r == Required)]
 
 instance FromJSON ParamDescription where
-  parseJSON (Object v) = do
+  parseJSON = withObject "ParamDescription" $ \v -> do
     req <- v .: "required"
     if req
       then ParamDesc <$> v .: "name" <*> v .: "help" <*> v .: "type" <*> pure Required
       else ParamDesc <$> v .: "name" <*> v .: "help" <*> v .: "type" <*> pure Optional
-  parseJSON _ = empty
 
 -- -------------------------------------
 
 instance ToJSON UntaggedCommandDescriptor where
   toJSON  = Object . jsWrite
 
 instance FromJSON UntaggedCommandDescriptor where
-  parseJSON (Object v) = jsRead v
-  parseJSON _ = empty
+  parseJSON = withObject "UntaggedCommandDescriptor" jsRead

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

@@ -13,7 +13,6 @@ import           Data.Aeson
 import           Control.Monad.IO.Class
 import           Control.Monad.STM
 import           Control.Monad.State.Strict
-import qualified Data.Aeson as A
 import qualified Data.Attoparsec.ByteString as AB
 import qualified Data.Attoparsec.ByteString.Char8 as AB
 import qualified Data.ByteString.Char8 as B
@@ -63,10 +62,10 @@ parseToJsonPipe oneShot cin cout cid =
                          cout
                          (cid + 1)
 
-jsonConsumer :: P.Consumer A.Value IO ()
+jsonConsumer :: P.Consumer Value IO ()
 jsonConsumer =
   do val <- P.await
-     liftIO $ BL.putStr (A.encode val)
+     liftIO $ BL.putStr (encode val)
      liftIO $ BL.putStr (BL.singleton $ fromIntegral (ord '\STX'))
      jsonConsumer
 
@@ -76,8 +75,8 @@ tchanProducer oneShot chan = do
   P.yield val
   unless oneShot $ tchanProducer False chan
 
-encodePipe :: P.Pipe ChannelResponse A.Value IO ()
-encodePipe = P.map (A.toJSON . channelToWire)
+encodePipe :: P.Pipe ChannelResponse Value IO ()
+encodePipe = P.map (toJSON . channelToWire)
 
 parseFrames
   :: forall m.
@@ -90,8 +89,8 @@ parseFrames prod0 = do
   if isEmpty then return () else go prod1
   where
     -- ignore inputs consisting only of space
-    terminatedJSON :: AB.Parser (Maybe A.Value)
-    terminatedJSON = (fmap Just $ A.json' <* AB.many' AB.space <* AB.endOfInput)
+    terminatedJSON :: AB.Parser (Maybe Value)
+    terminatedJSON = (fmap Just $ json' <* AB.many' AB.space <* AB.endOfInput)
                  <|> (AB.many' AB.space *> pure Nothing)
     -- endOfInput: we want to be sure that the given
     -- parser consumes the entirety of the given input
@@ -107,9 +106,9 @@ parseFrames prod0 = do
            let maybeWrappedRet :: Maybe (Either PAe.DecodingError WireRequest)
                maybeWrappedRet = case ret of
                                              Left parseErr -> pure $ Left $ PAe.AttoparsecError parseErr
-                                             Right (Just a) -> case A.fromJSON a of
-                                                                 A.Error err -> pure $ Left $ PAe.FromJSONError err
-                                                                 A.Success wireReq -> pure $ Right wireReq
+                                             Right (Just a) -> case fromJSON a of
+                                                                 Error err -> pure $ Left $ PAe.FromJSONError err
+                                                                 Success wireReq -> pure $ Right wireReq
                                              Right Nothing -> Nothing
            case maybeWrappedRet of
              Just wrappedRet -> P.yield wrappedRet
@@ -143,7 +142,7 @@ wireToChannel cout ri wr =
 -- ---------------------------------------------------------------------
 
 channelToWire :: ChannelResponse -> WireResponse
-channelToWire cr = WireResp $ A.toJSON $ coutResp cr
+channelToWire cr = WireResp $ toJSON $ coutResp cr
 
 -- ---------------------------------------------------------------------
 
@@ -152,28 +151,27 @@ data WireRequest = WireReq
   , params  :: ParamMap
   } deriving (Show,Eq)
 
-instance A.ToJSON WireRequest where
-    toJSON wr = A.object
-                [ "cmd" A..= cmd wr
-                , "params" A..= params wr
+instance ToJSON WireRequest where
+    toJSON wr = object
+                [ "cmd" .= cmd wr
+                , "params" .= params wr
                 ]
 
 
-instance A.FromJSON WireRequest where
-    parseJSON (A.Object v) = WireReq <$>
-                           v A..: "cmd" <*>
-                           v A..:? "params" A..!= Map.empty
-    -- A non-Object value is of the wrong type, so fail.
-    parseJSON _          = mzero
+instance FromJSON WireRequest where
+    parseJSON = withObject "WireRequest" $ \v ->
+      WireReq <$>
+      v .: "cmd" <*>
+      v .:? "params" .!= Map.empty
 
 -- ---------------------------------------------------------------------
 
-data WireResponse = WireResp A.Value
+data WireResponse = WireResp Value
                   deriving (Show,Eq)
 
-instance A.ToJSON WireResponse where
+instance ToJSON WireResponse where
     toJSON (WireResp val) = val
 
 
-instance A.FromJSON WireResponse where
+instance FromJSON WireResponse where
     parseJSON p = return $ WireResp p