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=2cbc41c07354f9c10f81ab902379085e52d5ed72;hb=d755a0a431e88fe5c4b2a62743ee78c3a51a55e5;hpb=12f6e7e7c1d2603712de134477a470bfa72ecf4b

diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs
index 2cbc41c..350b525 100644
--- a/src/Language/Haskell/LSP/Test/Decoding.hs
+++ b/src/Language/Haskell/LSP/Test/Decoding.hs
@@ -3,6 +3,7 @@ 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
@@ -11,7 +12,6 @@ import           System.IO
 import           System.IO.Error
 import           Language.Haskell.LSP.Types
 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
@@ -32,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
@@ -116,6 +116,7 @@ matchResponseMsgType req = case req of
   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)
@@ -123,7 +124,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
@@ -131,6 +132,9 @@ 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
@@ -138,6 +142,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
 
@@ -146,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