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