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
  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 FromClientMessage
  50
  51 getRequestMap :: [FromClientMessage] -> RequestMap
  52 getRequestMap = foldl helper HM.empty
  53  where
  54   helper acc msg = case msg of
  55     (ReqInitialize val) -> insert val msg acc
  56     (ReqShutdown val) -> insert val msg acc
  57     (ReqHover val) -> insert val msg acc
  58     (ReqCompletion val) -> insert val msg acc
  59     (ReqCompletionItemResolve val) -> insert val msg acc
  60     (ReqSignatureHelp val) -> insert val msg acc
  61     (ReqDefinition val) -> insert val msg acc
  62     (ReqFindReferences val) -> insert val msg acc
  63     (ReqDocumentHighlights val) -> insert val msg acc
  64     (ReqDocumentSymbols val) -> insert val msg acc
  65     (ReqWorkspaceSymbols val) -> insert val msg acc
  66     (ReqCodeAction val) -> insert val msg acc
  67     (ReqCodeLens val) -> insert val msg acc
  68     (ReqCodeLensResolve val) -> insert val msg acc
  69     (ReqDocumentFormatting val) -> insert val msg acc
  70     (ReqDocumentRangeFormatting val) -> insert val msg acc
  71     (ReqDocumentOnTypeFormatting val) -> insert val msg acc
  72     (ReqRename val) -> insert val msg acc
  73     (ReqExecuteCommand val) -> insert val msg acc
  74     (ReqDocumentLink val) -> insert val msg acc
  75     (ReqDocumentLinkResolve val) -> insert val msg acc
  76     (ReqWillSaveWaitUntil val) -> insert val msg acc
  77     _ -> acc
  78   insert m = HM.insert (m ^. id)
  79
  80 matchResponseMsgType :: FromClientMessage -> B.ByteString -> FromServerMessage
  81 matchResponseMsgType req bytes = case req of
  82   ReqInitialize _ -> RspInitialize $ fromJust $ decode bytes
  83   ReqShutdown   _ -> RspShutdown $ fromJust $ decode bytes
  84   ReqHover      _ -> RspHover $ fromJust $ decode bytes
  85   ReqCompletion _ -> RspCompletion $ fromJust $ decode bytes
  86   ReqCompletionItemResolve _ ->
  87     RspCompletionItemResolve $ fromJust $ decode bytes
  88   ReqSignatureHelp      _ -> RspSignatureHelp $ fromJust $ decode bytes
  89   ReqDefinition         _ -> RspDefinition $ fromJust $ decode bytes
  90   ReqFindReferences     _ -> RspFindReferences $ fromJust $ decode bytes
  91   ReqDocumentHighlights _ -> RspDocumentHighlights $ fromJust $ decode bytes
  92   ReqDocumentSymbols    _ -> RspDocumentSymbols $ fromJust $ decode bytes
  93   ReqWorkspaceSymbols   _ -> RspWorkspaceSymbols $ fromJust $ decode bytes
  94   ReqCodeAction         _ -> RspCodeAction $ fromJust $ decode bytes
  95   ReqCodeLens           _ -> RspCodeLens $ fromJust $ decode bytes
  96   ReqCodeLensResolve    _ -> RspCodeLensResolve $ fromJust $ decode bytes
  97   ReqDocumentFormatting _ -> RspDocumentFormatting $ fromJust $ decode bytes
  98   ReqDocumentRangeFormatting _ ->
  99     RspDocumentRangeFormatting $ fromJust $ decode bytes
 100   ReqDocumentOnTypeFormatting _ ->
 101     RspDocumentOnTypeFormatting $ fromJust $ decode bytes
 102   ReqRename              _ -> RspRename $ fromJust $ decode bytes
 103   ReqExecuteCommand      _ -> RspExecuteCommand $ fromJust $ decode bytes
 104   ReqDocumentLink        _ -> RspDocumentLink $ fromJust $ decode bytes
 105   ReqDocumentLinkResolve _ -> RspDocumentLinkResolve $ fromJust $ decode bytes
 106   ReqWillSaveWaitUntil   _ -> RspWillSaveWaitUntil $ fromJust $ decode bytes
 107   x                        -> error $ "Not a request: " ++ show x
 108
 109 decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
 110 decodeFromServerMsg reqMap bytes =
 111   case HM.lookup "method" (fromJust $ decode bytes :: Object) of
 112     Just methodStr -> case fromJSON methodStr of
 113       Success method -> case method of
 114         -- We can work out the type of the message
 115         TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes
 116         WindowShowMessage              -> NotShowMessage $ fromJust $ decode bytes
 117         WindowLogMessage               -> NotLogMessage $ fromJust $ decode bytes
 118         CancelRequestServer            -> NotCancelRequestFromServer $ fromJust $ decode bytes
 119         TelemetryEvent                 -> NotTelemetry $ fromJust $ decode bytes
 120         WindowShowMessageRequest       -> ReqShowMessage $ fromJust $ decode bytes
 121         ClientRegisterCapability       -> ReqRegisterCapability $ fromJust $ decode bytes
 122         ClientUnregisterCapability     -> ReqUnregisterCapability $ fromJust $ decode bytes
 123         WorkspaceApplyEdit             -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes
 124
 125       Error e -> error e
 126
 127     Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of
 128       Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of
 129         Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type
 130         Nothing  -> error "Couldn't match up response with request"
 131       Nothing -> error "Couldn't decode message"