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

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3
   4 module Language.Haskell.LSP.Test.Session
   5   ( Session
   6   , SessionConfig(..)
   7   , SessionContext(..)
   8   , SessionState(..)
   9   , MonadSessionConfig(..)
  10   , runSessionWithHandles
  11   , get
  12   , put
  13   , modify
  14   , modifyM
  15   , ask)
  16
  17 where
  18
  19 import Control.Concurrent hiding (yield)
  20 import Control.Exception
  21 import Control.Lens hiding (List)
  22 import Control.Monad
  23 import Control.Monad.IO.Class
  24 import Control.Monad.Except
  25 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
  26 import qualified Control.Monad.Trans.Reader as Reader (ask)
  27 import Control.Monad.Trans.State (StateT, runStateT)
  28 import qualified Control.Monad.Trans.State as State (get, put, modify)
  29 import qualified Data.ByteString.Lazy.Char8 as B
  30 import Data.Aeson
  31 import Data.Conduit hiding (await)
  32 import Data.Conduit.Parser
  33 import Data.Default
  34 import Data.Foldable
  35 import Data.List
  36 import qualified Data.Map as Map
  37 import qualified Data.Text as T
  38 import qualified Data.Text.IO as T
  39 import qualified Data.HashMap.Strict as HashMap
  40 import Data.Maybe
  41 import Language.Haskell.LSP.Messages
  42 import Language.Haskell.LSP.TH.ClientCapabilities
  43 import Language.Haskell.LSP.Types hiding (error)
  44 import Language.Haskell.LSP.VFS
  45 import Language.Haskell.LSP.Test.Compat
  46 import Language.Haskell.LSP.Test.Decoding
  47 import Language.Haskell.LSP.Test.Exceptions
  48 import System.Directory
  49 import System.IO
  50
  51 -- | A session representing one instance of launching and connecting to a server.
  52 --
  53 -- You can send and receive messages to the server within 'Session' via 'getMessage',
  54 -- 'sendRequest' and 'sendNotification'.
  55 --
  56 -- @
  57 -- runSession \"path\/to\/root\/dir\" $ do
  58 --   docItem <- getDocItem "Desktop/simple.hs" "haskell"
  59 --   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
  60 --   diagnostics <- getMessage :: Session PublishDiagnosticsNotification
  61 -- @
  62 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
  63
  64 -- | Stuff you can configure for a 'Session'.
  65 data SessionConfig = SessionConfig
  66   {
  67     capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything.
  68   , timeout :: Int -- ^ Maximum time to wait for a request in seconds. Defaults to 60.
  69   , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False
  70   }
  71
  72 instance Default SessionConfig where
  73   def = SessionConfig def 60 False
  74
  75 class Monad m => MonadSessionConfig m where
  76   sessionConfig :: m SessionConfig
  77
  78 instance Monad m => MonadSessionConfig (StateT SessionState (ReaderT SessionContext m)) where
  79   sessionConfig = config <$> lift Reader.ask
  80
  81 data SessionContext = SessionContext
  82   {
  83     serverIn :: Handle
  84   , rootDir :: FilePath
  85   , messageChan :: Chan FromServerMessage
  86   , requestMap :: MVar RequestMap
  87   , initRsp :: MVar InitializeResponse
  88   , config :: SessionConfig
  89   }
  90
  91 data SessionState = SessionState
  92   {
  93     curReqId :: LspId
  94   , vfs :: VFS
  95   , curDiagnostics :: Map.Map Uri [Diagnostic]
  96   }
  97
  98 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
  99
 100 type SessionProcessor = ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO))
 101
 102 runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
 103 runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
 104   where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
 105         handler e@(Unexpected "ConduitParser.empty") = do
 106
 107           -- Horrible way to get last item in conduit:
 108           -- Add a fake message so we can tell when to stop
 109           liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing))
 110           x <- peek
 111           case x of
 112             Just x -> do
 113               lastMsg <- skipToEnd x
 114               name <- getParserName
 115               liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
 116             Nothing -> throw e
 117
 118         handler e = throw e
 119
 120         skipToEnd x = do
 121           y <- peek
 122           case y of
 123             Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x
 124             Just _ -> await >>= skipToEnd
 125             Nothing -> return x
 126
 127 get :: Monad m => ParserStateReader a s r m s
 128 get = lift State.get
 129
 130 put :: Monad m => s -> ParserStateReader a s r m ()
 131 put = lift . State.put
 132
 133 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
 134 modify = lift . State.modify
 135
 136 modifyM :: Monad m => (s -> m s) -> ParserStateReader a s r m ()
 137 modifyM f = do
 138   old <- lift State.get
 139   new <- lift $ lift $ lift $ f old
 140   lift $ State.put new
 141
 142 ask :: Monad m => ParserStateReader a s r m r
 143 ask = lift $ lift Reader.ask
 144
 145 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 146 -- It also does not automatically send initialize and exit messages.
 147 runSessionWithHandles :: Handle -- ^ Server in
 148                       -> Handle -- ^ Server out
 149                       -> (Handle -> Session ()) -- ^ Server listener
 150                       -> SessionConfig
 151                       -> FilePath
 152                       -> Session a
 153                       -> IO a
 154 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
 155   absRootDir <- canonicalizePath rootDir
 156
 157   hSetBuffering serverIn  NoBuffering
 158   hSetBuffering serverOut NoBuffering
 159
 160   reqMap <- newMVar newRequestMap
 161   messageChan <- newChan
 162   meaninglessChan <- newChan
 163   initRsp <- newEmptyMVar
 164
 165   let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
 166       initState = SessionState (IdInt 0) mempty mempty
 167
 168   threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut)
 169   (result, _) <- runSession messageChan processor context initState session
 170
 171   killThread threadId
 172
 173   return result
 174
 175   where processor :: SessionProcessor ()
 176         processor = awaitForever $ \msg -> do
 177           processTextChanges msg
 178           yield msg
 179
 180
 181 processTextChanges :: FromServerMessage -> SessionProcessor ()
 182 processTextChanges (NotPublishDiagnostics n) = do
 183   let List diags = n ^. params . diagnostics
 184       doc = n ^. params . uri
 185   lift $ State.modify (\s ->
 186     let newDiags = Map.insert doc diags (curDiagnostics s)
 187       in s { curDiagnostics = newDiags })
 188
 189 processTextChanges (ReqApplyWorkspaceEdit r) = do
 190
 191   allChangeParams <- case r ^. params . edit . documentChanges of
 192     Just (List cs) -> do
 193       mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
 194       return $ map getParams cs
 195     Nothing -> case r ^. params . edit . changes of
 196       Just cs -> do
 197         mapM_ checkIfNeedsOpened (HashMap.keys cs)
 198         return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
 199       Nothing -> error "No changes!"
 200
 201   oldVFS <- vfs <$> lift State.get
 202   newVFS <- liftIO $ changeFromServerVFS oldVFS r
 203   lift $ State.modify (\s -> s { vfs = newVFS })
 204
 205   let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
 206       mergedParams = map mergeParams groupedParams
 207
 208   ctx <- lift $ lift Reader.ask
 209
 210   -- TODO: Don't do this when replaying a session
 211   forM_ mergedParams $ \p -> do
 212     let h = serverIn ctx
 213         msg = NotificationMessage "2.0" TextDocumentDidChange p
 214     liftIO $ B.hPut h $ addHeader (encode msg)
 215
 216   where checkIfNeedsOpened uri = do
 217           oldVFS <- vfs <$> lift State.get
 218           ctx <- lift $ lift Reader.ask
 219
 220           -- if its not open, open it
 221           unless (uri `Map.member` oldVFS) $ do
 222             let fp = fromJust $ uriToFilePath uri
 223             contents <- liftIO $ T.readFile fp
 224             let item = TextDocumentItem (filePathToUri fp) "" 0 contents
 225                 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
 226             liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
 227
 228             oldVFS <- vfs <$> lift State.get
 229             newVFS <- liftIO $ openVFS oldVFS msg
 230             lift $ State.modify (\s -> s { vfs = newVFS })
 231
 232         getParams (TextDocumentEdit docId (List edits)) =
 233           let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
 234             in DidChangeTextDocumentParams docId (List changeEvents)
 235
 236         textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..]
 237
 238         textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
 239
 240         getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
 241
 242         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
 243         mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
 244                               in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
 245 processTextChanges _ = return ()