src/Language/Haskell/LSP/Test/Decoding.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Language.Haskell.LSP.Test.Decoding where
   3
   4 import           Prelude                 hiding ( id )
   5 import           Data.Aeson
   6 import           Control.Lens
   7 import qualified Data.ByteString.Lazy.Char8    as B
   8 import           Data.Maybe
   9 import           System.IO
  10 import           Language.Haskell.LSP.Types
  11 import           Language.Haskell.LSP.Types.Lens hiding (error)
  12 import           Language.Haskell.LSP.Messages
  13 import qualified Data.HashMap.Strict           as HM
  14
  15 getAllMessages :: Handle -> IO [B.ByteString]
  16 getAllMessages h = do
  17   done <- hIsEOF h
  18   if done
  19     then return []
  20     else do
  21       msg <- getNextMessage h
  22
  23       (msg :) <$> getAllMessages h
  24
  25 -- | Fetches the next message bytes based on
  26 -- the Content-Length header
  27 getNextMessage :: Handle -> IO B.ByteString
  28 getNextMessage h = do
  29   headers <- getHeaders h
  30   case read . init <$> lookup "Content-Length" headers of
  31     Nothing   -> error "Couldn't read Content-Length header"
  32     Just size -> B.hGet h size
  33
  34 addHeader :: B.ByteString -> B.ByteString
  35 addHeader content = B.concat
  36   [ "Content-Length: "
  37   , B.pack $ show $ B.length content
  38   , "\r\n"
  39   , "\r\n"
  40   , content
  41   ]
  42
  43 getHeaders :: Handle -> IO [(String, String)]
  44 getHeaders h = do
  45   l <- hGetLine h
  46   let (name, val) = span (/= ':') l
  47   if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h
  48
  49 type RequestMap = HM.HashMap LspId ClientMethod
  50
  51 newRequestMap :: RequestMap
  52 newRequestMap = HM.empty
  53
  54 updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap
  55 updateRequestMap reqMap id method = HM.insert id method reqMap
  56
  57 getRequestMap :: [FromClientMessage] -> RequestMap
  58 getRequestMap = foldl helper HM.empty
  59  where
  60   helper acc msg = case msg of
  61     (ReqInitialize val) -> insert val acc
  62     (ReqShutdown val) -> insert val acc
  63     (ReqHover val) -> insert val acc
  64     (ReqCompletion val) -> insert val acc
  65     (ReqCompletionItemResolve val) -> insert val acc
  66     (ReqSignatureHelp val) -> insert val acc
  67     (ReqDefinition val) -> insert val acc
  68     (ReqFindReferences val) -> insert val acc
  69     (ReqDocumentHighlights val) -> insert val acc
  70     (ReqDocumentSymbols val) -> insert val acc
  71     (ReqWorkspaceSymbols val) -> insert val acc
  72     (ReqCodeAction val) -> insert val acc
  73     (ReqCodeLens val) -> insert val acc
  74     (ReqCodeLensResolve val) -> insert val acc
  75     (ReqDocumentFormatting val) -> insert val acc
  76     (ReqDocumentRangeFormatting val) -> insert val acc
  77     (ReqDocumentOnTypeFormatting val) -> insert val acc
  78     (ReqRename val) -> insert val acc
  79     (ReqExecuteCommand val) -> insert val acc
  80     (ReqDocumentLink val) -> insert val acc
  81     (ReqDocumentLinkResolve val) -> insert val acc
  82     (ReqWillSaveWaitUntil val) -> insert val acc
  83     _ -> acc
  84   insert m = HM.insert (m ^. id) (m ^. method)
  85
  86 matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage
  87 matchResponseMsgType req = case req of
  88   Initialize                    -> RspInitialize . decoded
  89   Shutdown                      -> RspShutdown . decoded
  90   TextDocumentHover             -> RspHover . decoded
  91   TextDocumentCompletion        -> RspCompletion . decoded
  92   CompletionItemResolve         -> RspCompletionItemResolve . decoded
  93   TextDocumentSignatureHelp     -> RspSignatureHelp . decoded
  94   TextDocumentDefinition        -> RspDefinition . decoded
  95   TextDocumentReferences        -> RspFindReferences . decoded
  96   TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded
  97   TextDocumentDocumentSymbol    -> RspDocumentSymbols . decoded
  98   WorkspaceSymbol               -> RspWorkspaceSymbols . decoded
  99   TextDocumentCodeAction        -> RspCodeAction . decoded
 100   TextDocumentCodeLens          -> RspCodeLens . decoded
 101   CodeLensResolve               -> RspCodeLensResolve . decoded
 102   TextDocumentFormatting        -> RspDocumentFormatting . decoded
 103   TextDocumentRangeFormatting   -> RspDocumentRangeFormatting . decoded
 104   TextDocumentOnTypeFormatting  -> RspDocumentOnTypeFormatting . decoded
 105   TextDocumentRename            -> RspRename . decoded
 106   WorkspaceExecuteCommand       -> RspExecuteCommand . decoded
 107   TextDocumentDocumentLink      -> RspDocumentLink . decoded
 108   DocumentLinkResolve           -> RspDocumentLinkResolve . decoded
 109   TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil . decoded
 110   x                             -> error . ((show x ++ " is not a request: ") ++) . show
 111   where decoded x = fromMaybe (error $ "Couldn't decode response for the request type: "
 112                                         ++ show req ++ "\n" ++ show x)
 113                               (decode x)
 114
 115 decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
 116 decodeFromServerMsg reqMap bytes =
 117   case HM.lookup "method" (fromJust $ decode bytes :: Object) of
 118     Just methodStr -> case fromJSON methodStr of
 119       Success method -> case method of
 120         -- We can work out the type of the message
 121         TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes
 122         WindowShowMessage              -> NotShowMessage $ fromJust $ decode bytes
 123         WindowLogMessage               -> NotLogMessage $ fromJust $ decode bytes
 124         CancelRequestServer            -> NotCancelRequestFromServer $ fromJust $ decode bytes
 125         TelemetryEvent                 -> NotTelemetry $ fromJust $ decode bytes
 126         WindowShowMessageRequest       -> ReqShowMessage $ fromJust $ decode bytes
 127         ClientRegisterCapability       -> ReqRegisterCapability $ fromJust $ decode bytes
 128         ClientUnregisterCapability     -> ReqUnregisterCapability $ fromJust $ decode bytes
 129         WorkspaceApplyEdit             -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes
 130         WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"
 131         WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"
 132
 133       Error e -> error e
 134
 135     Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of
 136       Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of
 137         Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type
 138         Nothing  -> error "Couldn't match up response with request"
 139       Nothing -> error "Couldn't decode message"