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