X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FDecoding.hs;h=27c7770ec461cdebe16a17868419b440f986081a;hb=2440adccbc46f22e5d1221bacc3d39512a0251cd;hp=059ab344dafad445003e0f066583cd779d5d79a1;hpb=fa0bdbf2ca975ea2493d0fcfaa6cb63c076567c1;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs
index 059ab34..27c7770 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           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
-import           Language.Haskell.LSP.Types.Lens hiding (error)
+import           Language.Haskell.LSP.Types.Lens
+                                         hiding ( error )
 import           Language.Haskell.LSP.Messages
+import           Language.Haskell.LSP.Test.Exceptions
 import qualified Data.HashMap.Strict           as HM
 
 getAllMessages :: Handle -> IO [B.ByteString]
@@ -42,9 +46,12 @@ 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
 
@@ -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
@@ -92,6 +100,7 @@ matchResponseMsgType req = case req of
   CompletionItemResolve         -> RspCompletionItemResolve . decoded
   TextDocumentSignatureHelp     -> RspSignatureHelp . decoded
   TextDocumentDefinition        -> RspDefinition . decoded
+  TextDocumentTypeDefinition    -> RspTypeDefinition . decoded
   TextDocumentReferences        -> RspFindReferences . decoded
   TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded
   TextDocumentDocumentSymbol    -> RspDocumentSymbols . decoded
@@ -114,7 +123,7 @@ matchResponseMsgType req = case req of
 
 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
@@ -122,6 +131,9 @@ decodeFromServerMsg reqMap bytes =
         WindowShowMessage              -> NotShowMessage $ fromJust $ decode bytes
         WindowLogMessage               -> NotLogMessage $ fromJust $ decode bytes
         CancelRequestServer            -> NotCancelRequestFromServer $ fromJust $ decode bytes
+        WindowProgressStart            -> NotProgressStart $ fromJust $ decode bytes
+        WindowProgressReport           -> NotProgressReport $ fromJust $ decode bytes
+        WindowProgressDone             -> NotProgressDone $ fromJust $ decode bytes
         TelemetryEvent                 -> NotTelemetry $ fromJust $ decode bytes
         WindowShowMessageRequest       -> ReqShowMessage $ fromJust $ decode bytes
         ClientRegisterCapability       -> ReqRegisterCapability $ fromJust $ decode bytes
@@ -129,6 +141,10 @@ decodeFromServerMsg reqMap 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
 
@@ -137,3 +153,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