diff --git a/lsp-types/src/Language/LSP/Types/Common.hs b/lsp-types/src/Language/LSP/Types/Common.hs index b57b39e72..62c3a2d6c 100644 --- a/lsp-types/src/Language/LSP/Types/Common.hs +++ b/lsp-types/src/Language/LSP/Types/Common.hs @@ -9,7 +9,6 @@ module Language.LSP.Types.Common where import Control.Applicative import Control.DeepSeq import Data.Aeson -import qualified Data.HashMap.Strict as HashMap import GHC.Generics -- | A terser, isomorphic data type for 'Either', that does not get tagged when @@ -55,5 +54,5 @@ instance ToJSON Empty where toJSON Empty = Null instance FromJSON Empty where parseJSON Null = pure Empty - parseJSON (Object o) | HashMap.null o = pure Empty + parseJSON (Object o) | o == mempty = pure Empty parseJSON _ = fail "expected 'null' or '{}'" diff --git a/lsp-types/src/Language/LSP/Types/Message.hs b/lsp-types/src/Language/LSP/Types/Message.hs index 452dbc3b7..f3277c519 100644 --- a/lsp-types/src/Language/LSP/Types/Message.hs +++ b/lsp-types/src/Language/LSP/Types/Message.hs @@ -55,12 +55,12 @@ import Language.LSP.Types.WatchedFiles import Language.LSP.Types.WorkspaceEdit import Language.LSP.Types.WorkspaceFolders import Language.LSP.Types.WorkspaceSymbol -import qualified Data.HashMap.Strict as HM import Data.Kind import Data.Aeson import Data.Aeson.TH import Data.Text (Text) +import Data.String import GHC.Generics -- --------------------------------------------------------------------- @@ -274,8 +274,8 @@ deriving instance Show (MessageParams m) => Show (RequestMessage m) -- | Replace a missing field in an object with a null field, to simplify parsing -- This is a hack to allow other types than Maybe to work like Maybe in allowing the field to be missing. -- See also this issue: https://github.com/haskell/aeson/issues/646 -addNullField :: Text -> Value -> Value -addNullField s (Object o) = Object $ HM.insertWith (\_new old -> old) s Null o +addNullField :: String -> Value -> Value +addNullField s (Object o) = Object $ o <> fromString s .= Null addNullField _ v = v instance (FromJSON (MessageParams m), FromJSON (SMethod m)) => FromJSON (RequestMessage m) where diff --git a/lsp-types/src/Language/LSP/Types/Parsing.hs b/lsp-types/src/Language/LSP/Types/Parsing.hs index ff7559f24..b1f6ac755 100644 --- a/lsp-types/src/Language/LSP/Types/Parsing.hs +++ b/lsp-types/src/Language/LSP/Types/Parsing.hs @@ -14,13 +14,13 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# LANGUAGE ScopedTypeVariables #-} module Language.LSP.Types.Parsing where import Language.LSP.Types.LspId import Language.LSP.Types.Method import Language.LSP.Types.Message -import qualified Data.HashMap.Strict as HM import Data.Aeson import Data.Aeson.Types @@ -90,25 +90,26 @@ Notification | jsonrpc | | method | params? {-# INLINE parseServerMessage #-} parseServerMessage :: LookupFunc FromClient a -> Value -> Parser (FromServerMessage' a) parseServerMessage lookupId v@(Object o) = do - case HM.lookup "method" o of - Just cmd -> do - -- Request or Notification - SomeServerMethod m <- parseJSON cmd + methMaybe <- o .:! "method" + idMaybe <- o .:! "id" + case methMaybe of + -- Request or Notification + Just (SomeServerMethod m) -> case splitServerMethod m of IsServerNot -> FromServerMess m <$> parseJSON v IsServerReq -> FromServerMess m <$> parseJSON v - IsServerEither - | HM.member "id" o -- Request - , SCustomMethod cm <- m -> + IsServerEither | SCustomMethod cm <- m -> do + case idMaybe of + -- Request + Just _ -> let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Request)) - in FromServerMess m' <$> parseJSON v - | SCustomMethod cm <- m -> + in FromServerMess m' <$> parseJSON v + Nothing -> let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromServer Notification)) - in FromServerMess m' <$> parseJSON v + in FromServerMess m' <$> parseJSON v Nothing -> do - case HM.lookup "id" o of - Just i' -> do - i <- parseJSON i' + case idMaybe of + Just i -> do case lookupId i of Just (m,res) -> clientResponseJSON m $ FromServerRsp res <$> parseJSON v Nothing -> fail $ unwords ["Failed in looking up response type of", show v] @@ -118,25 +119,26 @@ parseServerMessage _ v = fail $ unwords ["parseServerMessage expected object, go {-# INLINE parseClientMessage #-} parseClientMessage :: LookupFunc FromServer a -> Value -> Parser (FromClientMessage' a) parseClientMessage lookupId v@(Object o) = do - case HM.lookup "method" o of - Just cmd -> do - -- Request or Notification - SomeClientMethod m <- parseJSON cmd + methMaybe <- o .:! "method" + idMaybe <- o .:! "id" + case methMaybe of + -- Request or Notification + Just (SomeClientMethod m) -> case splitClientMethod m of IsClientNot -> FromClientMess m <$> parseJSON v IsClientReq -> FromClientMess m <$> parseJSON v - IsClientEither - | HM.member "id" o -- Request - , SCustomMethod cm <- m -> + IsClientEither | SCustomMethod cm <- m -> do + case idMaybe of + -- Request + Just _ -> let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Request)) - in FromClientMess m' <$> parseJSON v - | SCustomMethod cm <- m -> + in FromClientMess m' <$> parseJSON v + Nothing -> let m' = (SCustomMethod cm :: SMethod (CustomMethod :: Method FromClient Notification)) - in FromClientMess m' <$> parseJSON v + in FromClientMess m' <$> parseJSON v Nothing -> do - case HM.lookup "id" o of - Just i' -> do - i <- parseJSON i' + case idMaybe of + Just i -> do case lookupId i of Just (m,res) -> serverResponseJSON m $ FromClientRsp res <$> parseJSON v Nothing -> fail $ unwords ["Failed in looking up response type of", show v] diff --git a/lsp/example/Reactor.hs b/lsp/example/Reactor.hs index cbe7d7965..a4c3a8174 100644 --- a/lsp/example/Reactor.hs +++ b/lsp/example/Reactor.hs @@ -30,7 +30,6 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM import qualified Data.Aeson as J -import qualified Data.HashMap.Strict as H import qualified Data.Text as T import GHC.Generics (Generic) import Language.LSP.Server @@ -263,8 +262,8 @@ handle = mconcat cmd = "lsp-hello-command" -- need 'file' and 'start_pos' args = J.List - [ J.Object $ H.fromList [("file", J.Object $ H.fromList [("textDocument",J.toJSON doc)])] - , J.Object $ H.fromList [("start_pos",J.Object $ H.fromList [("position", J.toJSON start)])] + [ J.object [("file", J.object [("textDocument",J.toJSON doc)])] + , J.object [("start_pos",J.object [("position", J.toJSON start)])] ] cmdparams = Just args makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = []