X-Git-Url: https://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FDecoding.hs;h=350b5251ad8b49133d3be5086852e3984f682a8c;hp=f71a52fe9620641a87cae74bfdbd8686d1346e13;hb=d755a0a431e88fe5c4b2a62743ee78c3a51a55e5;hpb=f1238f8db54eafbf0e3352140818875ad4cfd997

diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs
index f71a52f..350b525 100644
--- a/src/Language/Haskell/LSP/Test/Decoding.hs
+++ b/src/Language/Haskell/LSP/Test/Decoding.hs
@@ -3,13 +3,17 @@ module Language.Haskell.LSP.Test.Decoding where
 
 import           Prelude                 hiding ( id )
 import           Data.Aeson
+import           Data.Foldable
+import           Control.Exception
 import           Control.Lens
 import qualified Data.ByteString.Lazy.Char8    as B
 import           Data.Maybe
 import           System.IO
+import           System.IO.Error
 import           Language.Haskell.LSP.Types
-                                         hiding ( error )
+import           Language.Haskell.LSP.Types.Lens
 import           Language.Haskell.LSP.Messages
+import           Language.Haskell.LSP.Test.Exceptions
 import qualified Data.HashMap.Strict           as HM
 
 getAllMessages :: Handle -> IO [B.ByteString]
@@ -28,7 +32,7 @@ getNextMessage :: Handle -> IO B.ByteString
 getNextMessage h = do
   headers <- getHeaders h
   case read . init <$> lookup "Content-Length" headers of
-    Nothing   -> error "Couldn't read Content-Length header"
+    Nothing   -> throw NoContentLengthHeader
     Just size -> B.hGet h size
 
 addHeader :: B.ByteString -> B.ByteString
@@ -42,17 +46,20 @@ addHeader content = B.concat
 
 getHeaders :: Handle -> IO [(String, String)]
 getHeaders h = do
-  l <- hGetLine h
+  l <- catch (hGetLine h) eofHandler
   let (name, val) = span (/= ':') l
   if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h
+  where eofHandler e
+          | isEOFError e = throw UnexpectedServerTermination
+          | otherwise = throw e
 
 type RequestMap = HM.HashMap LspId ClientMethod
 
 newRequestMap :: RequestMap
 newRequestMap = HM.empty
 
-updateRequestMap :: RequestMap -> RequestMessage ClientMethod a b -> RequestMap
-updateRequestMap reqMap msg = HM.insert (msg ^. id) (msg ^. method) reqMap
+updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap
+updateRequestMap reqMap id method = HM.insert id method reqMap
 
 getRequestMap :: [FromClientMessage] -> RequestMap
 getRequestMap = foldl helper HM.empty
@@ -65,6 +72,7 @@ getRequestMap = foldl helper HM.empty
     (ReqCompletionItemResolve val) -> insert val acc
     (ReqSignatureHelp val) -> insert val acc
     (ReqDefinition val) -> insert val acc
+    (ReqTypeDefinition val) -> insert val acc
     (ReqFindReferences val) -> insert val acc
     (ReqDocumentHighlights val) -> insert val acc
     (ReqDocumentSymbols val) -> insert val acc
@@ -84,34 +92,39 @@ getRequestMap = foldl helper HM.empty
   insert m = HM.insert (m ^. id) (m ^. method)
 
 matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage
-matchResponseMsgType req bytes = case req of
-  Initialize                    -> RspInitialize $ fromJust $ decode bytes
-  Shutdown                      -> RspShutdown $ fromJust $ decode bytes
-  TextDocumentHover             -> RspHover $ fromJust $ decode bytes
-  TextDocumentCompletion        -> RspCompletion $ fromJust $ decode bytes
-  CompletionItemResolve         -> RspCompletionItemResolve $ fromJust $ decode bytes
-  TextDocumentSignatureHelp     -> RspSignatureHelp $ fromJust $ decode bytes
-  TextDocumentDefinition        -> RspDefinition $ fromJust $ decode bytes
-  TextDocumentReferences        -> RspFindReferences $ fromJust $ decode bytes
-  TextDocumentDocumentHighlight -> RspDocumentHighlights $ fromJust $ decode bytes
-  TextDocumentDocumentSymbol    -> RspDocumentSymbols $ fromJust $ decode bytes
-  WorkspaceSymbol               -> RspWorkspaceSymbols $ fromJust $ decode bytes
-  TextDocumentCodeAction        -> RspCodeAction $ fromJust $ decode bytes
-  TextDocumentCodeLens          -> RspCodeLens $ fromJust $ decode bytes
-  CodeLensResolve               -> RspCodeLensResolve $ fromJust $ decode bytes
-  TextDocumentFormatting        -> RspDocumentFormatting $ fromJust $ decode bytes
-  TextDocumentRangeFormatting   -> RspDocumentRangeFormatting $ fromJust $ decode bytes
-  TextDocumentOnTypeFormatting  -> RspDocumentOnTypeFormatting $ fromJust $ decode bytes
-  TextDocumentRename            -> RspRename $ fromJust $ decode bytes
-  WorkspaceExecuteCommand       -> RspExecuteCommand $ fromJust $ decode bytes
-  TextDocumentDocumentLink      -> RspDocumentLink $ fromJust $ decode bytes
-  DocumentLinkResolve           -> RspDocumentLinkResolve $ fromJust $ decode bytes
-  TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil $ fromJust $ decode bytes
-  x                             -> error $ "Not a request: " ++ show x
+matchResponseMsgType req = case req of
+  Initialize                    -> RspInitialize . decoded
+  Shutdown                      -> RspShutdown . decoded
+  TextDocumentHover             -> RspHover . decoded
+  TextDocumentCompletion        -> RspCompletion . decoded
+  CompletionItemResolve         -> RspCompletionItemResolve . decoded
+  TextDocumentSignatureHelp     -> RspSignatureHelp . decoded
+  TextDocumentDefinition        -> RspDefinition . decoded
+  TextDocumentTypeDefinition    -> RspTypeDefinition . decoded
+  TextDocumentReferences        -> RspFindReferences . decoded
+  TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded
+  TextDocumentDocumentSymbol    -> RspDocumentSymbols . decoded
+  WorkspaceSymbol               -> RspWorkspaceSymbols . decoded
+  TextDocumentCodeAction        -> RspCodeAction . decoded
+  TextDocumentCodeLens          -> RspCodeLens . decoded
+  CodeLensResolve               -> RspCodeLensResolve . decoded
+  TextDocumentFormatting        -> RspDocumentFormatting . decoded
+  TextDocumentRangeFormatting   -> RspDocumentRangeFormatting . decoded
+  TextDocumentOnTypeFormatting  -> RspDocumentOnTypeFormatting . decoded
+  TextDocumentRename            -> RspRename . decoded
+  WorkspaceExecuteCommand       -> RspExecuteCommand . decoded
+  TextDocumentDocumentLink      -> RspDocumentLink . decoded
+  DocumentLinkResolve           -> RspDocumentLinkResolve . decoded
+  TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil . decoded
+  CustomClientMethod{}          -> RspCustomServer . decoded
+  x                             -> error . ((show x ++ " is not a request: ") ++) . show
+  where decoded x = fromMaybe (error $ "Couldn't decode response for the request type: "
+                                        ++ show req ++ "\n" ++ show x)
+                              (decode x)
 
 decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
 decodeFromServerMsg reqMap bytes =
-  case HM.lookup "method" (fromJust $ decode bytes :: Object) of
+  case HM.lookup "method" obj of
     Just methodStr -> case fromJSON methodStr of
       Success method -> case method of
         -- We can work out the type of the message
@@ -119,11 +132,20 @@ decodeFromServerMsg reqMap bytes =
         WindowShowMessage              -> NotShowMessage $ fromJust $ decode bytes
         WindowLogMessage               -> NotLogMessage $ fromJust $ decode bytes
         CancelRequestServer            -> NotCancelRequestFromServer $ fromJust $ decode bytes
+        Progress                       ->
+          fromJust $ asum [NotWorkDoneProgressBegin <$> decode bytes, NotWorkDoneProgressReport <$> decode bytes, NotWorkDoneProgressEnd <$> decode bytes]
+        WindowWorkDoneProgressCreate   -> ReqWorkDoneProgressCreate $ fromJust $ decode bytes
         TelemetryEvent                 -> NotTelemetry $ fromJust $ decode bytes
         WindowShowMessageRequest       -> ReqShowMessage $ fromJust $ decode bytes
         ClientRegisterCapability       -> ReqRegisterCapability $ fromJust $ decode bytes
         ClientUnregisterCapability     -> ReqUnregisterCapability $ fromJust $ decode bytes
         WorkspaceApplyEdit             -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes
+        WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"
+        WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"
+        CustomServerMethod _
+            | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes
+            | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes
+            | otherwise -> NotCustomServer $ fromJust $ decode bytes
 
       Error e -> error e
 
@@ -132,3 +154,4 @@ decodeFromServerMsg reqMap bytes =
         Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type
         Nothing  -> error "Couldn't match up response with request"
       Nothing -> error "Couldn't decode message"
+    where obj = fromJust $ decode bytes :: Object