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

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