src/Language/Haskell/LSP/Test.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE RankNTypes #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE ExistentialQuantification #-}
   5
   6 module Language.Haskell.LSP.Test
   7   (
   8   -- * Sessions
   9     runSession
  10   , Session
  11   -- * Sending
  12   , sendRequest
  13   , sendNotification
  14   -- * Receving
  15   , getMessage
  16   -- * Utilities
  17   , getDocItem
  18   , getDocUri
  19   ) where
  20
  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
  28 import Data.Aeson
  29 import qualified Data.ByteString.Lazy.Char8 as B
  30 import Data.Default
  31 import Data.Maybe
  32 import Data.Proxy
  33 import System.Process
  34 import Language.Haskell.LSP.Types hiding (error, id)
  35 import Compat
  36 import System.IO
  37 import System.Directory
  38 import System.FilePath
  39 import Language.Haskell.LSP.Test.Parsing
  40
  41 data SessionContext = SessionContext
  42   {
  43     messageSema :: MVar B.ByteString,
  44     serverIn :: Handle,
  45     serverOut :: Handle,
  46     rootDir :: FilePath
  47   }
  48
  49 newtype SessionState = SessionState
  50   {
  51     curReqId :: LspId
  52   }
  53 type Session = StateT SessionState (ReaderT SessionContext IO)
  54
  55 runSession :: FilePath -> Session a -> IO ()
  56 runSession rootDir session = do
  57
  58   absRootDir <- canonicalizePath rootDir
  59
  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 }
  63
  64   hSetBuffering serverIn  NoBuffering
  65   hSetBuffering serverOut NoBuffering
  66
  67   pid <- getProcessID
  68   messageSema <- newEmptyMVar
  69
  70   let initializeParams :: InitializeParams
  71       initializeParams = InitializeParams (Just pid)
  72                                               (Just $ T.pack absRootDir)
  73                                               (Just $ filePathToUri absRootDir)
  74                                               Nothing
  75                                               def
  76                                               (Just TraceOff)
  77       context = SessionContext messageSema serverIn serverOut absRootDir
  78       initState = SessionState (IdInt 9)
  79
  80       -- | The session wrapped around initialize and shutdown calls
  81       fullSession = do
  82         sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams
  83         (ResponseMessage _ _ (Just (InitializeResponseCapabilities _)) e) <- getMessage
  84         liftIO $ maybe (return ()) (putStrLn . ("Error when initializing: " ++) . show ) e
  85
  86         sendNotification Initialized InitializedParams
  87
  88         -- Run the actual thing
  89         session
  90
  91         sendNotification Exit ExitParams
  92
  93   forkIO $ listenServer context
  94   _ <- runReaderT (runStateT fullSession initState) context
  95
  96   terminateProcess serverProc
  97
  98   return ()
  99
 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)
 105
 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
 113
 114   listenServer context
 115
 116 -- | Sends a request to the server.
 117 sendRequest
 118   :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp)
 119   => Proxy (RequestMessage ClientMethod params resp)
 120   -> ClientMethod
 121   -> params
 122   -> Session LspId
 123 sendRequest _ method params = do
 124   h <- serverIn <$> lift ask
 125
 126   id <- curReqId <$> get
 127   get >>= \c -> put c { curReqId = nextId id }
 128
 129   let msg = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp
 130
 131   liftIO $ B.hPut h $ addHeader (encode msg)
 132
 133   return id
 134
 135   where nextId (IdInt i) = IdInt (i + 1)
 136         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 137
 138 -- | Sends a notification to the server.
 139 sendNotification :: ToJSON a => ClientMethod -> a -> Session ()
 140 sendNotification method params = do
 141   h <- serverIn <$> lift ask
 142
 143   let msg = NotificationMessage "2.0" method params
 144   liftIO $ B.hPut h $ addHeader (encode msg)
 145
 146 -- | Reads in a message from the server.
 147 getMessage :: FromJSON a => Session a
 148 getMessage = do
 149   sema <- messageSema <$> lift ask
 150   bytes <- liftIO $ takeMVar sema
 151   return $ fromMaybe (error $ "Wrong type! Got: " ++ show bytes) (decode bytes)
 152
 153 -- | Reads in a text document as the first version.
 154 getDocItem :: FilePath
 155            -- ^ The path to the text document to read in.
 156            -> String
 157            -- ^ The language ID, e.g "haskell" for .hs files.
 158            -> Session TextDocumentItem
 159 getDocItem file languageId = do
 160   context <- lift ask
 161   let fp = rootDir context </> file
 162   contents <- liftIO $ T.readFile fp
 163   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 164
 165 -- | Gets the Uri for the file corrected to the session directory.
 166 getDocUri :: FilePath -> Session Uri
 167 getDocUri file = do
 168   context <- lift ask
 169   let fp = rootDir context </> file
 170   return $ filePathToUri fp