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

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module Language.Haskell.LSP.Test.Session
   4   ( Session
   5   , SessionState(..)
   6   , SessionContext(..)
   7   , runSessionWithHandles
   8   , get
   9   , put
  10   , modify
  11   , ask)
  12
  13 where
  14
  15 import Control.Concurrent hiding (yield)
  16 import Control.Lens hiding (List)
  17 import Control.Monad
  18 import Control.Monad.IO.Class
  19 import Control.Monad.Trans.Class
  20 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
  21 import qualified Control.Monad.Trans.Reader as Reader (ask)
  22 import Control.Monad.Trans.State (StateT, runStateT)
  23 import qualified Control.Monad.Trans.State as State (get, put, modify)
  24 import qualified Data.ByteString.Lazy.Char8 as B
  25 import Data.Aeson
  26 import Data.Conduit
  27 import Data.Conduit.Parser
  28 import Data.Foldable
  29 import Data.List
  30 import qualified Data.HashMap.Strict as HashMap
  31 import Language.Haskell.LSP.Messages
  32 import Language.Haskell.LSP.Types
  33 import Language.Haskell.LSP.VFS
  34 import Language.Haskell.LSP.Test.Compat
  35 import Language.Haskell.LSP.Test.Decoding
  36 import System.Directory
  37 import System.IO
  38
  39 data SessionContext = SessionContext
  40   {
  41     serverIn :: Handle
  42   , rootDir :: FilePath
  43   , messageChan :: Chan FromServerMessage
  44   , requestMap :: MVar RequestMap
  45   , initRsp :: MVar InitializeResponse
  46   }
  47
  48 data SessionState = SessionState
  49   {
  50     curReqId :: LspId
  51   , vfs :: VFS
  52   }
  53
  54 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
  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 type SessionProcessor = ConduitT FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO))
  70
  71 runSession' :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
  72 runSession' chan preprocessor context state session = runReaderT (runStateT conduit state) context
  73   where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser session
  74
  75 get :: Monad m => ParserStateReader a s r m s
  76 get = lift State.get
  77
  78 put :: Monad m => s -> ParserStateReader a s r m ()
  79 put = lift . State.put
  80
  81 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
  82 modify = lift . State.modify
  83
  84 ask :: Monad m => ParserStateReader a s r m r
  85 ask = lift $ lift Reader.ask
  86
  87 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
  88 -- It also does not automatically send initialize and exit messages.
  89 runSessionWithHandles :: Handle -- ^ Server in
  90                       -> Handle -- ^ Server out
  91                       -> (Handle -> Session ()) -- ^ Server listener
  92                       -> FilePath
  93                       -> Session a
  94                       -> IO a
  95 runSessionWithHandles serverIn serverOut serverHandler rootDir session = do
  96   absRootDir <- canonicalizePath rootDir
  97
  98   hSetBuffering serverIn  NoBuffering
  99   hSetBuffering serverOut NoBuffering
 100
 101   reqMap <- newMVar newRequestMap
 102   messageChan <- newChan
 103   meaninglessChan <- newChan
 104   initRsp <- newEmptyMVar
 105
 106   let context = SessionContext serverIn absRootDir messageChan reqMap initRsp
 107       initState = SessionState (IdInt 0) mempty
 108
 109   threadId <- forkIO $ void $ runSession' meaninglessChan processor context initState (serverHandler serverOut)
 110   (result, _) <- runSession' messageChan processor context initState session
 111
 112   killThread threadId
 113
 114   return result
 115
 116   where processor :: SessionProcessor ()
 117         processor = awaitForever $ \msg -> do
 118           processTextChanges msg
 119           yield msg
 120
 121
 122 processTextChanges :: FromServerMessage -> SessionProcessor ()
 123 processTextChanges (ReqApplyWorkspaceEdit r) = do
 124   List changeParams <- case r ^. params . edit . documentChanges of
 125     Just cs -> mapM applyTextDocumentEdit cs
 126     Nothing -> case r ^. params . edit . changes of
 127       Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs))
 128       Nothing -> return (List [])
 129
 130   let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams
 131       mergedParams = map mergeParams groupedParams
 132
 133   -- TODO: Don't do this when replaying a session
 134   forM_ mergedParams $ \p -> do
 135     h <- serverIn <$> lift (lift Reader.ask)
 136     let msg = NotificationMessage "2.0" TextDocumentDidChange p
 137     liftIO $ B.hPut h $ addHeader (encode msg)
 138
 139   where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do
 140           oldVFS <- vfs <$> lift State.get
 141           let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
 142               params = DidChangeTextDocumentParams docId (List changeEvents)
 143           newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params)
 144           lift $ State.modify (\s -> s { vfs = newVFS })
 145           return params
 146
 147         applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits)
 148
 149         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
 150         mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
 151                               in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
 152 processTextChanges _ = return ()