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

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