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   , ask)
  15
  16 where
  17
  18 import Control.Concurrent hiding (yield)
  19 import Control.Exception
  20 import Control.Lens hiding (List)
  21 import Control.Monad
  22 import Control.Monad.IO.Class
  23 import Control.Monad.Except
  24 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
  25 import qualified Control.Monad.Trans.Reader as Reader (ask)
  26 import Control.Monad.Trans.State (StateT, runStateT)
  27 import qualified Control.Monad.Trans.State as State (get, put, modify)
  28 import qualified Data.ByteString.Lazy.Char8 as B
  29 import Data.Aeson
  30 import Data.Conduit hiding (await)
  31 import Data.Conduit.Parser
  32 import Data.Default
  33 import Data.Foldable
  34 import Data.List
  35 import qualified Data.Text as T
  36 import qualified Data.HashMap.Strict as HashMap
  37 import Language.Haskell.LSP.Messages
  38 import Language.Haskell.LSP.TH.ClientCapabilities
  39 import Language.Haskell.LSP.Types
  40 import Language.Haskell.LSP.VFS
  41 import Language.Haskell.LSP.Test.Compat
  42 import Language.Haskell.LSP.Test.Decoding
  43 import Language.Haskell.LSP.Test.Exceptions
  44 import System.Directory
  45 import System.IO
  46
  47 -- | A session representing one instance of launching and connecting to a server.
  48 --
  49 -- You can send and receive messages to the server within 'Session' via 'getMessage',
  50 -- 'sendRequest' and 'sendNotification'.
  51 --
  52 -- @
  53 -- runSession \"path\/to\/root\/dir\" $ do
  54 --   docItem <- getDocItem "Desktop/simple.hs" "haskell"
  55 --   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
  56 --   diagnostics <- getMessage :: Session PublishDiagnosticsNotification
  57 -- @
  58 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
  59
  60 -- | Stuff you can configure for a 'Session'.
  61 data SessionConfig = SessionConfig
  62   {
  63     capabilities :: ClientCapabilities, -- ^ Specific capabilities the client should advertise.
  64     timeout :: Int -- ^ Maximum time to wait for a request in seconds.
  65   }
  66
  67 instance Default SessionConfig where
  68   def = SessionConfig def 60
  69
  70 class Monad m => MonadSessionConfig m where
  71   sessionConfig :: m SessionConfig
  72
  73 instance Monad m => MonadSessionConfig (StateT SessionState (ReaderT SessionContext m)) where
  74   sessionConfig = config <$> lift Reader.ask
  75
  76 data SessionContext = SessionContext
  77   {
  78     serverIn :: Handle
  79   , rootDir :: FilePath
  80   , messageChan :: Chan FromServerMessage
  81   , requestMap :: MVar RequestMap
  82   , initRsp :: MVar InitializeResponse
  83   , config :: SessionConfig
  84   }
  85
  86 data SessionState = SessionState
  87   {
  88     curReqId :: LspId
  89   , vfs :: VFS
  90   }
  91
  92 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
  93
  94 type SessionProcessor = ConduitT FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO))
  95
  96 runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
  97 runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
  98   where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
  99         handler e@(Unexpected "ConduitParser.empty") = do
 100
 101           -- Horrible way to get last item in conduit:
 102           -- Add a fake message so we can tell when to stop
 103           liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing))
 104           x <- peek
 105           case x of
 106             Just x -> do
 107               lastMsg <- skipToEnd x
 108               name <- getParserName
 109               liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
 110             Nothing -> throw e
 111
 112         handler e = throw e
 113
 114         skipToEnd x = do
 115           y <- peek
 116           case y of
 117             Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x
 118             Just _ -> await >>= skipToEnd
 119             Nothing -> return x
 120
 121 get :: Monad m => ParserStateReader a s r m s
 122 get = lift State.get
 123
 124 put :: Monad m => s -> ParserStateReader a s r m ()
 125 put = lift . State.put
 126
 127 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
 128 modify = lift . State.modify
 129
 130 ask :: Monad m => ParserStateReader a s r m r
 131 ask = lift $ lift Reader.ask
 132
 133 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 134 -- It also does not automatically send initialize and exit messages.
 135 runSessionWithHandles :: Handle -- ^ Server in
 136                       -> Handle -- ^ Server out
 137                       -> (Handle -> Session ()) -- ^ Server listener
 138                       -> SessionConfig
 139                       -> FilePath
 140                       -> Session a
 141                       -> IO a
 142 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
 143   absRootDir <- canonicalizePath rootDir
 144
 145   hSetBuffering serverIn  NoBuffering
 146   hSetBuffering serverOut NoBuffering
 147
 148   reqMap <- newMVar newRequestMap
 149   messageChan <- newChan
 150   meaninglessChan <- newChan
 151   initRsp <- newEmptyMVar
 152
 153   let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
 154       initState = SessionState (IdInt 0) mempty
 155
 156   threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut)
 157   (result, _) <- runSession messageChan processor context initState session
 158
 159   killThread threadId
 160
 161   return result
 162
 163   where processor :: SessionProcessor ()
 164         processor = awaitForever $ \msg -> do
 165           processTextChanges msg
 166           yield msg
 167
 168
 169 processTextChanges :: FromServerMessage -> SessionProcessor ()
 170 processTextChanges (ReqApplyWorkspaceEdit r) = do
 171   List changeParams <- case r ^. params . edit . documentChanges of
 172     Just cs -> mapM applyTextDocumentEdit cs
 173     Nothing -> case r ^. params . edit . changes of
 174       Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs))
 175       Nothing -> return (List [])
 176
 177   let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams
 178       mergedParams = map mergeParams groupedParams
 179
 180   -- TODO: Don't do this when replaying a session
 181   forM_ mergedParams $ \p -> do
 182     h <- serverIn <$> lift (lift Reader.ask)
 183     let msg = NotificationMessage "2.0" TextDocumentDidChange p
 184     liftIO $ B.hPut h $ addHeader (encode msg)
 185
 186   where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do
 187           oldVFS <- vfs <$> lift State.get
 188           let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
 189               params = DidChangeTextDocumentParams docId (List changeEvents)
 190           newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params)
 191           lift $ State.modify (\s -> s { vfs = newVFS })
 192           return params
 193
 194         applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits)
 195
 196         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
 197         mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
 198                               in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
 199 processTextChanges _ = return ()