Add more helpers for code actions and commands

Generialize session classes

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 2a6db1fd459e711be61ebe67764d10543c2ef342..b406e7bd4e87a5a068d59b44e7b27678b100a64e 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -63,14 +63,21 @@ module Language.Haskell.LSP.Test
   , satisfy
   -- * Utilities
   , initializeResponse
+  -- ** Documents
   , openDoc
   , documentContents
   , getDocumentEdit
   , getDocUri
-  , noDiagnostics
+  -- ** Symbols
   , getDocumentSymbols
+  -- ** Diagnostics
   , waitForDiagnostics
+  , noDiagnostics
+  -- ** Commands
+  , executeCommand
+  -- ** Code Actions
   , getAllCodeActions
+  , executeCodeAction
   ) where
 
 import Control.Applicative
@@ -83,13 +90,13 @@ import Control.Lens hiding ((.=), List)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Aeson
-import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Default
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Map as Map
 import Data.Maybe
-import Language.Haskell.LSP.Types hiding (id, capabilities)
+import Language.Haskell.LSP.Types hiding (id, capabilities, error)
 import qualified Language.Haskell.LSP.Types as LSP
+import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.VFS
 import Language.Haskell.LSP.Test.Compat
 import Language.Haskell.LSP.Test.Decoding
@@ -97,7 +104,6 @@ import Language.Haskell.LSP.Test.Exceptions
 import Language.Haskell.LSP.Test.Parsing
 import Language.Haskell.LSP.Test.Session
 import Language.Haskell.LSP.Test.Server
-import System.Console.ANSI
 import System.IO
 import System.Directory
 import System.FilePath
@@ -280,20 +286,6 @@ sendNotification' = sendMessage
 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 sendResponse = sendMessage
 
-sendMessage :: ToJSON a => a -> Session ()
-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)
-
-
-
 -- | Returns the initialize response that was received from the server.
 -- The initialize requests and responses are not included the session,
 -- so if you need to test it use this.
@@ -363,3 +355,19 @@ getAllCodeActions doc = do
         Nothing ->
           let Just (List cmdOrCAs) = mRes
             in return (acc ++ cmdOrCAs)
+
+executeCommand :: Command -> Session ()
+executeCommand cmd = do
+  let args = decode $ encode $ fromJust $ cmd ^. arguments
+      execParams = ExecuteCommandParams (cmd ^. command) args
+  sendRequest_ WorkspaceExecuteCommand execParams
+
+executeCodeAction :: CodeAction -> Session ()
+executeCodeAction action = do
+  maybe (return ()) handleEdit $ action ^. edit
+  maybe (return ()) executeCommand $ action ^. command
+
+  where handleEdit :: WorkspaceEdit -> Session ()
+        handleEdit e =
+          let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
+            in processMessage (ReqApplyWorkspaceEdit req)
\ No newline at end of file

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index 641077c83ccaeca38d67990ac6cb056498d5e7fe..ec6d45dc1ed3fbb18ebb8e239cf2d08287762ed6 100644 (file)
--- 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)
@@ -45,6 +49,7 @@ 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,6 +93,17 @@ 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
@@ -95,10 +111,27 @@ data SessionState = SessionState
   , 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))
 
+
 runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
 runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
   where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
@@ -124,24 +157,6 @@ 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
@@ -174,19 +189,19 @@ runSessionWithHandles serverIn serverOut serverHandler config rootDir session =
 
   where processor :: SessionProcessor ()
         processor = awaitForever $ \msg -> do
-          processTextChanges msg
+          processMessage msg
           yield msg
 
 
-processTextChanges :: FromServerMessage -> SessionProcessor ()
-processTextChanges (NotPublishDiagnostics n) = do
+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
-  lift $ State.modify (\s ->
+  modify (\s ->
     let newDiags = Map.insert doc diags (curDiagnostics s) 
       in s { curDiagnostics = newDiags })
 
-processTextChanges (ReqApplyWorkspaceEdit r) = do
+processMessage (ReqApplyWorkspaceEdit r) = do
 
   allChangeParams <- case r ^. params . edit . documentChanges of
     Just (List cs) -> do
@@ -198,24 +213,19 @@ processTextChanges (ReqApplyWorkspaceEdit r) = do
         return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
       Nothing -> error "No changes!"
 
-  oldVFS <- vfs <$> lift State.get
+  oldVFS <- vfs <$> get
   newVFS <- liftIO $ changeFromServerVFS oldVFS r
-  lift $ State.modify (\s -> s { vfs = newVFS })
+  modify (\s -> s { vfs = newVFS })
 
   let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
       mergedParams = map mergeParams groupedParams
 
-  ctx <- lift $ lift Reader.ask
-
   -- 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)
+  forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
 
   where checkIfNeedsOpened uri = do
-          oldVFS <- vfs <$> lift State.get
-          ctx <- lift $ lift Reader.ask
+          oldVFS <- vfs <$> get
+          ctx <- ask
 
           -- if its not open, open it
           unless (uri `Map.member` oldVFS) $ do
@@ -225,9 +235,9 @@ processTextChanges (ReqApplyWorkspaceEdit r) = do
                 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 })
+            modify (\s -> s { vfs = newVFS })
 
         getParams (TextDocumentEdit docId (List edits)) =
           let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
@@ -242,4 +252,16 @@ processTextChanges (ReqApplyWorkspaceEdit r) = do
         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)