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
  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   }
  70
  71 instance Default SessionConfig where
  72   def = SessionConfig def 60
  73
  74 class Monad m => MonadSessionConfig m where
  75   sessionConfig :: m SessionConfig
  76
  77 instance Monad m => MonadSessionConfig (StateT SessionState (ReaderT SessionContext m)) where
  78   sessionConfig = config <$> lift Reader.ask
  79
  80 data SessionContext = SessionContext
  81   {
  82     serverIn :: Handle
  83   , rootDir :: FilePath
  84   , messageChan :: Chan FromServerMessage
  85   , requestMap :: MVar RequestMap
  86   , initRsp :: MVar InitializeResponse
  87   , config :: SessionConfig
  88   }
  89
  90 data SessionState = SessionState
  91   {
  92     curReqId :: LspId
  93   , vfs :: VFS
  94   }
  95
  96 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
  97
  98 type SessionProcessor = ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO))
  99
 100 runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
 101 runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
 102   where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
 103         handler e@(Unexpected "ConduitParser.empty") = do
 104
 105           -- Horrible way to get last item in conduit:
 106           -- Add a fake message so we can tell when to stop
 107           liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing))
 108           x <- peek
 109           case x of
 110             Just x -> do
 111               lastMsg <- skipToEnd x
 112               name <- getParserName
 113               liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
 114             Nothing -> throw e
 115
 116         handler e = throw e
 117
 118         skipToEnd x = do
 119           y <- peek
 120           case y of
 121             Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x
 122             Just _ -> await >>= skipToEnd
 123             Nothing -> return x
 124
 125 get :: Monad m => ParserStateReader a s r m s
 126 get = lift State.get
 127
 128 put :: Monad m => s -> ParserStateReader a s r m ()
 129 put = lift . State.put
 130
 131 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
 132 modify = lift . State.modify
 133
 134 modifyM :: Monad m => (s -> m s) -> ParserStateReader a s r m ()
 135 modifyM f = do
 136   old <- lift State.get
 137   new <- lift $ lift $ lift $ f old
 138   lift $ State.put new
 139
 140 ask :: Monad m => ParserStateReader a s r m r
 141 ask = lift $ lift Reader.ask
 142
 143 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 144 -- It also does not automatically send initialize and exit messages.
 145 runSessionWithHandles :: Handle -- ^ Server in
 146                       -> Handle -- ^ Server out
 147                       -> (Handle -> Session ()) -- ^ Server listener
 148                       -> SessionConfig
 149                       -> FilePath
 150                       -> Session a
 151                       -> IO a
 152 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
 153   absRootDir <- canonicalizePath rootDir
 154
 155   hSetBuffering serverIn  NoBuffering
 156   hSetBuffering serverOut NoBuffering
 157
 158   reqMap <- newMVar newRequestMap
 159   messageChan <- newChan
 160   meaninglessChan <- newChan
 161   initRsp <- newEmptyMVar
 162
 163   let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
 164       initState = SessionState (IdInt 0) mempty
 165
 166   threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut)
 167   (result, _) <- runSession messageChan processor context initState session
 168
 169   killThread threadId
 170
 171   return result
 172
 173   where processor :: SessionProcessor ()
 174         processor = awaitForever $ \msg -> do
 175           processTextChanges msg
 176           yield msg
 177
 178
 179 processTextChanges :: FromServerMessage -> SessionProcessor ()
 180 processTextChanges (ReqApplyWorkspaceEdit r) = do
 181   changeParams <- case r ^. params . edit . documentChanges of
 182     Just (List cs) -> mapM applyTextDocumentEdit cs
 183     Nothing -> case r ^. params . edit . changes of
 184       Just cs -> concat <$> mapM (uncurry applyChange) (HashMap.toList cs)
 185       Nothing -> return []
 186
 187   let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams
 188       mergedParams = map mergeParams groupedParams
 189
 190   ctx <- lift $ lift Reader.ask
 191
 192   -- TODO: Don't do this when replaying a session
 193   forM_ mergedParams $ \p -> do
 194     let h = serverIn ctx
 195         msg = NotificationMessage "2.0" TextDocumentDidChange p
 196     liftIO $ B.hPut h $ addHeader (encode msg)
 197
 198   where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do
 199           oldVFS <- vfs <$> lift State.get
 200           ctx <- lift $ lift Reader.ask
 201
 202
 203           -- if its not open, open it
 204           unless ((docId ^. uri) `Map.member` oldVFS) $ do
 205             let fp = fromJust $ uriToFilePath (docId ^. uri)
 206             contents <- liftIO $ T.readFile fp
 207             let item = TextDocumentItem (filePathToUri fp) "" 0 contents
 208                 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
 209             liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
 210
 211             oldVFS <- vfs <$> lift State.get
 212             newVFS <- liftIO $ openVFS oldVFS msg
 213             lift $ State.modify (\s -> s { vfs = newVFS })
 214
 215           -- we might have updated it above
 216           oldVFS <- vfs <$> lift State.get
 217
 218           let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
 219               params = DidChangeTextDocumentParams docId (List changeEvents)
 220           newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params)
 221           lift $ State.modify (\s -> s { vfs = newVFS })
 222
 223           return params
 224
 225         textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..]
 226
 227         textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
 228
 229         applyChange uri (List edits) = mapM applyTextDocumentEdit (textDocumentEdits uri (reverse edits))
 230
 231         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
 232         mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
 233                               in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
 234 processTextChanges _ = return ()