X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=eb75fda1db2c8fd5d5c1bdf010f77dd5544cb30a;hb=fe5448266f5db772dd3f10be432cd56581bbcb40;hp=b38d1b7fe1d4885de1354036be174aa10f484c93;hpb=269f303e5e44fba835c51eacfca622c488a06b9f;p=opengl.git diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index b38d1b7..eb75fda 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} module Language.Haskell.LSP.Test.Session ( Session @@ -11,8 +13,10 @@ module Language.Haskell.LSP.Test.Session , get , put , modify - , modifyM - , ask) + , ask + , asks + , sendMessage + , processMessage) where @@ -25,7 +29,7 @@ import Control.Monad.Except import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader (ask) import Control.Monad.Trans.State (StateT, runStateT) -import qualified Control.Monad.Trans.State as State (get, put, modify) +import qualified Control.Monad.Trans.State as State (get, put) import qualified Data.ByteString.Lazy.Char8 as B import Data.Aeson import Data.Conduit hiding (await) @@ -40,11 +44,12 @@ import qualified Data.HashMap.Strict as HashMap import Data.Maybe import Language.Haskell.LSP.Messages import Language.Haskell.LSP.TH.ClientCapabilities -import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types hiding (error) import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Exceptions +import System.Console.ANSI import System.Directory import System.IO @@ -88,12 +93,40 @@ data SessionContext = SessionContext , config :: SessionConfig } +class Monad m => HasReader r m where + ask :: m r + asks :: (r -> b) -> m b + asks f = f <$> ask + +instance Monad m => HasReader r (ParserStateReader a s r m) where + ask = lift $ lift Reader.ask + +instance HasReader SessionContext SessionProcessor where + ask = lift $ lift Reader.ask + data SessionState = SessionState { curReqId :: LspId , vfs :: VFS + , curDiagnostics :: Map.Map Uri [Diagnostic] } +class Monad m => HasState s m where + get :: m s + + put :: s -> m () + + modify :: (s -> s) -> m () + modify f = get >>= put . f + +instance Monad m => HasState s (ParserStateReader a s r m) where + get = lift State.get + put = lift . State.put + +instance HasState SessionState SessionProcessor where + get = lift State.get + put = lift . State.put + type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) type SessionProcessor = ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) @@ -123,29 +156,11 @@ runSession chan preprocessor context state session = runReaderT (runStateT condu Just _ -> await >>= skipToEnd Nothing -> return x -get :: Monad m => ParserStateReader a s r m s -get = lift State.get - -put :: Monad m => s -> ParserStateReader a s r m () -put = lift . State.put - -modify :: Monad m => (s -> s) -> ParserStateReader a s r m () -modify = lift . State.modify - -modifyM :: Monad m => (s -> m s) -> ParserStateReader a s r m () -modifyM f = do - old <- lift State.get - new <- lift $ lift $ lift $ f old - lift $ State.put new - -ask :: Monad m => ParserStateReader a s r m r -ask = lift $ lift Reader.ask - -- | An internal version of 'runSession' that allows for a custom handler to listen to the server. -- It also does not automatically send initialize and exit messages. runSessionWithHandles :: Handle -- ^ Server in -> Handle -- ^ Server out - -> (Handle -> Session ()) -- ^ Server listener + -> (Handle -> SessionContext -> IO ()) -- ^ Server listener -> SessionConfig -> FilePath -> Session a @@ -158,13 +173,12 @@ runSessionWithHandles serverIn serverOut serverHandler config rootDir session = reqMap <- newMVar newRequestMap messageChan <- newChan - meaninglessChan <- newChan initRsp <- newEmptyMVar let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config - initState = SessionState (IdInt 0) mempty + initState = SessionState (IdInt 0) mempty mempty - threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut) + threadId <- forkIO $ void $ serverHandler serverOut context (result, _) <- runSession messageChan processor context initState session killThread threadId @@ -173,63 +187,83 @@ runSessionWithHandles serverIn serverOut serverHandler config rootDir session = where processor :: SessionProcessor () processor = awaitForever $ \msg -> do - processTextChanges msg + processMessage msg yield msg -processTextChanges :: FromServerMessage -> SessionProcessor () -processTextChanges (ReqApplyWorkspaceEdit r) = do - changeParams <- case r ^. params . edit . documentChanges of - Just (List cs) -> mapM applyTextDocumentEdit cs +processMessage :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m () +processMessage (NotPublishDiagnostics n) = do + let List diags = n ^. params . diagnostics + doc = n ^. params . uri + modify (\s -> + let newDiags = Map.insert doc diags (curDiagnostics s) + in s { curDiagnostics = newDiags }) + +processMessage (ReqApplyWorkspaceEdit r) = do + + allChangeParams <- case r ^. params . edit . documentChanges of + Just (List cs) -> do + mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs + return $ map getParams cs Nothing -> case r ^. params . edit . changes of - Just cs -> concat <$> mapM (uncurry applyChange) (HashMap.toList cs) - Nothing -> return [] + Just cs -> do + mapM_ checkIfNeedsOpened (HashMap.keys cs) + return $ concatMap (uncurry getChangeParams) (HashMap.toList cs) + Nothing -> error "No changes!" - let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams - mergedParams = map mergeParams groupedParams + oldVFS <- vfs <$> get + newVFS <- liftIO $ changeFromServerVFS oldVFS r + modify (\s -> s { vfs = newVFS }) - ctx <- lift $ lift Reader.ask + let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams + mergedParams = map mergeParams groupedParams -- TODO: Don't do this when replaying a session - forM_ mergedParams $ \p -> do - let h = serverIn ctx - msg = NotificationMessage "2.0" TextDocumentDidChange p - liftIO $ B.hPut h $ addHeader (encode msg) - - where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do - oldVFS <- vfs <$> lift State.get - ctx <- lift $ lift Reader.ask + forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange) + where checkIfNeedsOpened uri = do + oldVFS <- vfs <$> get + ctx <- ask -- if its not open, open it - unless ((docId ^. uri) `Map.member` oldVFS) $ do - let fp = fromJust $ uriToFilePath (docId ^. uri) + unless (uri `Map.member` oldVFS) $ do + let fp = fromJust $ uriToFilePath uri contents <- liftIO $ T.readFile fp let item = TextDocumentItem (filePathToUri fp) "" 0 contents msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item) liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg) - oldVFS <- vfs <$> lift State.get + oldVFS <- vfs <$> get newVFS <- liftIO $ openVFS oldVFS msg - lift $ State.modify (\s -> s { vfs = newVFS }) - - -- we might have updated it above - oldVFS <- vfs <$> lift State.get + modify (\s -> s { vfs = newVFS }) + getParams (TextDocumentEdit docId (List edits)) = let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits - params = DidChangeTextDocumentParams docId (List changeEvents) - newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params) - lift $ State.modify (\s -> s { vfs = newVFS }) - - return params + in DidChangeTextDocumentParams docId (List changeEvents) textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..] textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits - applyChange uri (List edits) = mapM applyTextDocumentEdit (textDocumentEdits uri (reverse edits)) + getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits)) mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params)) in DidChangeTextDocumentParams (head params ^. textDocument) (List events) -processTextChanges _ = return () +processMessage _ = return () + +sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m () +sendMessage msg = do + h <- serverIn <$> ask + let encoded = encode msg + liftIO $ do + + setSGR [SetColor Foreground Vivid Cyan] + putStrLn $ "--> " ++ B.unpack encoded + setSGR [Reset] + + B.hPut h (addHeader encoded) + +-- withTimeout :: Int -> Session a -> Session a +-- withTimeout duration = do +-- liftIO $ fork threadDelay