1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE RankNTypes #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# LANGUAGE ExistentialQuantification #-}
6 module Language.Haskell.LSP.Test
21 import Control.Monad.Trans.Class
22 import Control.Monad.IO.Class
23 import Control.Monad.Trans.Reader
24 import Control.Monad.Trans.State
25 import Control.Concurrent
26 import qualified Data.Text as T
27 import qualified Data.Text.IO as T
29 import qualified Data.ByteString.Lazy.Char8 as B
34 import Language.Haskell.LSP.Types hiding (error, id)
37 import System.Directory
38 import System.FilePath
39 import Language.Haskell.LSP.Test.Parsing
41 data SessionContext = SessionContext
43 messageSema :: MVar B.ByteString,
49 newtype SessionState = SessionState
53 type Session = StateT SessionState (ReaderT SessionContext IO)
55 runSession :: FilePath -> Session a -> IO ()
56 runSession rootDir session = do
58 absRootDir <- canonicalizePath rootDir
60 (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
61 (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
62 { std_in = CreatePipe, std_out = CreatePipe }
64 hSetBuffering serverIn NoBuffering
65 hSetBuffering serverOut NoBuffering
68 messageSema <- newEmptyMVar
70 let initializeParams :: InitializeParams
71 initializeParams = InitializeParams (Just pid)
72 (Just $ T.pack absRootDir)
73 (Just $ filePathToUri absRootDir)
77 context = SessionContext messageSema serverIn serverOut absRootDir
78 initState = SessionState (IdInt 9)
80 -- | The session wrapped around initialize and shutdown calls
82 sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams
83 (ResponseMessage _ _ (Just (InitializeResponseCapabilities _)) e) <- getMessage
84 liftIO $ maybe (return ()) (putStrLn . ("Error when initializing: " ++) . show ) e
86 sendNotification Initialized InitializedParams
88 -- Run the actual thing
91 sendNotification Exit ExitParams
93 forkIO $ listenServer context
94 _ <- runReaderT (runStateT fullSession initState) context
96 terminateProcess serverProc
100 -- | Listens to the server output, makes sure it matches the record and
101 -- signals any semaphores
102 listenServer :: SessionContext -> IO ()
103 listenServer context = do
104 msgBytes <- getNextMessage (serverOut context)
106 case decode msgBytes :: Maybe LogMessageNotification of
107 -- Just print log and show messages
108 Just (NotificationMessage _ WindowLogMessage (LogMessageParams _ msg)) -> T.putStrLn msg
109 _ -> case decode msgBytes :: Maybe ShowMessageNotification of
110 Just (NotificationMessage _ WindowShowMessage (ShowMessageParams _ msg)) -> T.putStrLn msg
111 -- Give everything else for getMessage to handle
112 _ -> putMVar (messageSema context) msgBytes
116 -- | Sends a request to the server.
118 :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp)
119 => Proxy (RequestMessage ClientMethod params resp)
123 sendRequest _ method params = do
124 h <- serverIn <$> lift ask
126 id <- curReqId <$> get
127 get >>= \c -> put c { curReqId = nextId id }
129 let msg = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp
131 liftIO $ B.hPut h $ addHeader (encode msg)
135 where nextId (IdInt i) = IdInt (i + 1)
136 nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
138 -- | Sends a notification to the server.
139 sendNotification :: ToJSON a => ClientMethod -> a -> Session ()
140 sendNotification method params = do
141 h <- serverIn <$> lift ask
143 let msg = NotificationMessage "2.0" method params
144 liftIO $ B.hPut h $ addHeader (encode msg)
146 -- | Reads in a message from the server.
147 getMessage :: FromJSON a => Session a
149 sema <- messageSema <$> lift ask
150 bytes <- liftIO $ takeMVar sema
151 return $ fromMaybe (error $ "Wrong type! Got: " ++ show bytes) (decode bytes)
153 -- | Reads in a text document as the first version.
154 getDocItem :: FilePath
155 -- ^ The path to the text document to read in.
157 -- ^ The language ID, e.g "haskell" for .hs files.
158 -> Session TextDocumentItem
159 getDocItem file languageId = do
161 let fp = rootDir context </> file
162 contents <- liftIO $ T.readFile fp
163 return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
165 -- | Gets the Uri for the file corrected to the session directory.
166 getDocUri :: FilePath -> Session Uri
169 let fp = rootDir context </> file
170 return $ filePathToUri fp