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 runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
 135 runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
 136   where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
 137         handler e@(Unexpected "ConduitParser.empty") = do
 138
 139           -- Horrible way to get last item in conduit:
 140           -- Add a fake message so we can tell when to stop
 141           liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing))
 142           x <- peek
 143           case x of
 144             Just x -> do
 145               lastMsg <- skipToEnd x
 146               name <- getParserName
 147               liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
 148             Nothing -> throw e
 149
 150         handler e = throw e
 151
 152         skipToEnd x = do
 153           y <- peek
 154           case y of
 155             Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x
 156             Just _ -> await >>= skipToEnd
 157             Nothing -> return x
 158
 159 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 160 -- It also does not automatically send initialize and exit messages.
 161 runSessionWithHandles :: Handle -- ^ Server in
 162                       -> Handle -- ^ Server out
 163                       -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
 164                       -> SessionConfig
 165                       -> FilePath
 166                       -> Session a
 167                       -> IO a
 168 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
 169   absRootDir <- canonicalizePath rootDir
 170
 171   hSetBuffering serverIn  NoBuffering
 172   hSetBuffering serverOut NoBuffering
 173
 174   reqMap <- newMVar newRequestMap
 175   messageChan <- newChan
 176   initRsp <- newEmptyMVar
 177
 178   let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
 179       initState = SessionState (IdInt 0) mempty mempty
 180
 181   threadId <- forkIO $ void $ serverHandler serverOut context
 182   (result, _) <- runSession messageChan processor context initState session
 183
 184   killThread threadId
 185
 186   return result
 187
 188   where processor :: SessionProcessor ()
 189         processor = awaitForever $ \msg -> do
 190           processMessage msg
 191           yield msg
 192
 193
 194 processMessage :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
 195 processMessage (NotPublishDiagnostics n) = do
 196   let List diags = n ^. params . diagnostics
 197       doc = n ^. params . uri
 198   modify (\s ->
 199     let newDiags = Map.insert doc diags (curDiagnostics s)
 200       in s { curDiagnostics = newDiags })
 201
 202 processMessage (ReqApplyWorkspaceEdit r) = do
 203
 204   allChangeParams <- case r ^. params . edit . documentChanges of
 205     Just (List cs) -> do
 206       mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
 207       return $ map getParams cs
 208     Nothing -> case r ^. params . edit . changes of
 209       Just cs -> do
 210         mapM_ checkIfNeedsOpened (HashMap.keys cs)
 211         return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
 212       Nothing -> error "No changes!"
 213
 214   oldVFS <- vfs <$> get
 215   newVFS <- liftIO $ changeFromServerVFS oldVFS r
 216   modify (\s -> s { vfs = newVFS })
 217
 218   let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
 219       mergedParams = map mergeParams groupedParams
 220
 221   -- TODO: Don't do this when replaying a session
 222   forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
 223
 224   where checkIfNeedsOpened uri = do
 225           oldVFS <- vfs <$> get
 226           ctx <- ask
 227
 228           -- if its not open, open it
 229           unless (uri `Map.member` oldVFS) $ do
 230             let fp = fromJust $ uriToFilePath uri
 231             contents <- liftIO $ T.readFile fp
 232             let item = TextDocumentItem (filePathToUri fp) "" 0 contents
 233                 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
 234             liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
 235
 236             oldVFS <- vfs <$> get
 237             newVFS <- liftIO $ openVFS oldVFS msg
 238             modify (\s -> s { vfs = newVFS })
 239
 240         getParams (TextDocumentEdit docId (List edits)) =
 241           let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
 242             in DidChangeTextDocumentParams docId (List changeEvents)
 243
 244         textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..]
 245
 246         textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
 247
 248         getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
 249
 250         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
 251         mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
 252                               in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
 253 processMessage _ = return ()
 254
 255 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
 256 sendMessage msg = do
 257   h <- serverIn <$> ask
 258   let encoded = encode msg
 259   liftIO $ do
 260
 261     setSGR [SetColor Foreground Vivid Cyan]
 262     putStrLn $ "--> " ++ B.unpack encoded
 263     setSGR [Reset]
 264
 265     B.hPut h (addHeader encoded)
 266
 267 -- withTimeout :: Int -> Session a -> Session a
 268 -- withTimeout duration = do
 269 --   liftIO $ fork threadDelay