ffb0563 · ghcide · git.iko.soy

ghcide.cabal+1

compare with master

unifiedsplit

@@ -101,6 +101,7 @@ library

101 exposed-modules:

102 Development.IDE.Core.Debouncer

103 Development.IDE.Core.FileStore

104+ Development.IDE.Core.IdeConfiguration

104 Development.IDE.Core.OfInterest

105 Development.IDE.Core.OfInterest

105 Development.IDE.Core.PositionMapping

106 Development.IDE.Core.PositionMapping

106 Development.IDE.Core.Rules

107 Development.IDE.Core.Rules

src/Development/IDE/Core/FileExists.hs+11−2

@@ -19,6 +19,7 @@ import qualified Data.HashMap.Strict as HashMap

19import Data.Maybe

20import qualified Data.Text as T

21import Development.IDE.Core.FileStore

22+import Development.IDE.Core.IdeConfiguration

22import Development.IDE.Core.Shake

23import Development.IDE.Core.Shake

23import Development.IDE.Types.Location

24import Development.IDE.Types.Location

24import Development.Shake

25import Development.Shake

@@ -101,6 +102,11 @@ fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()

101fileExistsRulesFast getLspId vfs = do

102fileExistsRulesFast getLspId vfs = do

102 addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])

103 addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])

103 defineEarlyCutoff $ \GetFileExists file -> do

104 defineEarlyCutoff $ \GetFileExists file -> do

105+ isWf <- isWorkspaceFile file

106+ if isWf then fileExistsFast getLspId vfs file else fileExistsSlow vfs file

107+

108+fileExistsFast :: IO LspId -> VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))

109+fileExistsFast getLspId vfs file = do

104 fileExistsMap <- getFileExistsMapUntracked

110 fileExistsMap <- getFileExistsMapUntracked

105 let mbFilesWatched = HashMap.lookup file fileExistsMap

111 let mbFilesWatched = HashMap.lookup file fileExistsMap

106 case mbFilesWatched of

112 case mbFilesWatched of

@@ -145,8 +151,11 @@ summarizeExists :: Bool -> Maybe BS.ByteString

145summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty

151summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty

146

152

147fileExistsRulesSlow:: VFSHandle -> Rules ()

153fileExistsRulesSlow:: VFSHandle -> Rules ()

148−fileExistsRulesSlow vfs = do

154+fileExistsRulesSlow vfs =

149− defineEarlyCutoff $ \GetFileExists file -> do

155+ defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file

156+

157+fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))

158+fileExistsSlow vfs file = do

150 alwaysRerun

159 alwaysRerun

151 exist <- liftIO $ getFileExistsVFS vfs file

160 exist <- liftIO $ getFileExistsVFS vfs file

152 pure (summarizeExists exist, ([], Just exist))

161 pure (summarizeExists exist, ([], Just exist))

src/Development/IDE/Core/IdeConfiguration.hsnew file+66

@@ -0,0 +1,66 @@

1+{-# LANGUAGE DuplicateRecordFields #-}

2+module Development.IDE.Core.IdeConfiguration

3+ ( IdeConfiguration(..)

4+ , registerIdeConfiguration

5+ , parseConfiguration

6+ , parseWorkspaceFolder

7+ , isWorkspaceFile

8+ , modifyWorkspaceFolders

9+ )

10+where

11+

12+import Control.Concurrent.Extra

13+import Control.Monad

14+import Data.HashSet (HashSet, singleton)

15+import Data.Text (Text, isPrefixOf)

16+import Development.IDE.Core.Shake

17+import Development.IDE.Types.Location

18+import Development.Shake

19+import Language.Haskell.LSP.Types

20+

21+-- | Lsp client relevant configuration details

22+data IdeConfiguration = IdeConfiguration

23+ { workspaceFolders :: HashSet NormalizedUri

24+ }

25+ deriving (Show)

26+

27+newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration}

28+

29+instance IsIdeGlobal IdeConfigurationVar

30+

31+registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()

32+registerIdeConfiguration extras =

33+ addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar

34+

35+getIdeConfiguration :: Action IdeConfiguration

36+getIdeConfiguration =

37+ getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef

38+

39+parseConfiguration :: InitializeRequest -> IdeConfiguration

40+parseConfiguration RequestMessage { _params = InitializeParams {..} } =

41+ IdeConfiguration { .. }

42+ where

43+ workspaceFolders =

44+ foldMap (singleton . toNormalizedUri) _rootUri

45+ <> (foldMap . foldMap)

46+ (singleton . parseWorkspaceFolder)

47+ _workspaceFolders

48+

49+parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri

50+parseWorkspaceFolder =

51+ toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)

52+

53+modifyWorkspaceFolders

54+ :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()

55+modifyWorkspaceFolders ide f = do

56+ IdeConfigurationVar var <- getIdeGlobalState ide

57+ IdeConfiguration ws <- readVar var

58+ writeVar var (IdeConfiguration (f ws))

59+

60+isWorkspaceFile :: NormalizedFilePath -> Action Bool

61+isWorkspaceFile file = do

62+ IdeConfiguration {..} <- getIdeConfiguration

63+ let toText = getUri . fromNormalizedUri

64+ return $ any

65+ (\root -> toText root `isPrefixOf` toText (filePathToUri' file))

66+ workspaceFolders

src/Development/IDE/Core/Shake.hs+8−6

@@ -19,7 +19,7 @@

19-- always stored as real Haskell values, whereas Shake serialises all 'A' values

20-- between runs. To deserialise a Shake value, we just consult Values.

21module Development.IDE.Core.Shake(

22− IdeState,

22+ IdeState, shakeExtras,

23 ShakeExtras(..), getShakeExtras,

24 IdeRule, IdeResult, GetModificationTime(..),

25 shakeOpen, shakeShut,

@@ -30,7 +30,7 @@ module Development.IDE.Core.Shake(

30 define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,

31 getDiagnostics, unsafeClearDiagnostics,

32 getHiddenDiagnostics,

33− IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,

33+ IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,

34 garbageCollect,

35 setPriority,

36 sendEvent,

@@ -114,13 +114,15 @@ getShakeExtrasRules = do

114 Just x <- getShakeExtraRules @ShakeExtras

115 return x

116

117−

118−

119class Typeable a => IsIdeGlobal a where

117class Typeable a => IsIdeGlobal a where

120

118

121addIdeGlobal :: IsIdeGlobal a => a -> Rules ()

119addIdeGlobal :: IsIdeGlobal a => a -> Rules ()

122−addIdeGlobal x@(typeOf -> ty) = do

120+addIdeGlobal x = do

121+ extras <- getShakeExtrasRules

122+ liftIO $ addIdeGlobalExtras extras x

123+

124+addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()

123− ShakeExtras{globals} <- getShakeExtrasRules

125+addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =

124 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

126 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

125 Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty

127 Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty

126 Nothing -> return $! HMap.insert ty (toDyn x) mp

128 Nothing -> return $! HMap.insert ty (toDyn x) mp

src/Development/IDE/LSP/LanguageServer.hs+12−7

@@ -28,10 +28,11 @@ import GHC.IO.Handle (hDuplicate)

28import System.IO

29import Control.Monad.Extra

30

31+import Development.IDE.Core.IdeConfiguration

32+import Development.IDE.Core.Shake

31import Development.IDE.LSP.HoverDefinition

33import Development.IDE.LSP.HoverDefinition

32import Development.IDE.LSP.Notifications

34import Development.IDE.LSP.Notifications

33import Development.IDE.LSP.Outline

35import Development.IDE.LSP.Outline

34−import Development.IDE.Core.Service

35import Development.IDE.Types.Logger

36import Development.IDE.Types.Logger

36import Development.IDE.Core.FileStore

37import Development.IDE.Core.FileStore

37import Language.Haskell.LSP.Core (LspFuncs(..))

38import Language.Haskell.LSP.Core (LspFuncs(..))

@@ -105,8 +106,8 @@ runLanguageServer options userHandlers getIdeState = do

105 handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def

106 handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def

106

107

107 let initializeCallbacks = LSP.InitializeCallbacks

108 let initializeCallbacks = LSP.InitializeCallbacks

108− { LSP.onInitialConfiguration = const $ Right ()

109+ { LSP.onInitialConfiguration = Right . parseConfiguration

109− , LSP.onConfigurationChange = const $ Right ()

110+ , LSP.onConfigurationChange = const $ Left "Configuration changes not supported yet"

110 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan

111 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan

111 }

112 }

112

113

@@ -121,9 +122,13 @@ runLanguageServer options userHandlers getIdeState = do

121 , void $ waitBarrier clientMsgBarrier

122 , void $ waitBarrier clientMsgBarrier

122 ]

123 ]

123 where

124 where

124− handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)

125+ handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs IdeConfiguration -> IO (Maybe err)

125 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do

126 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do

127+

126 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities

128 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities

129+

130+ mapM_ (registerIdeConfiguration (shakeExtras ide)) =<< config

131+

127 _ <- flip forkFinally (const exitClientMsg) $ forever $ do

132 _ <- flip forkFinally (const exitClientMsg) $ forever $ do

128 msg <- readChan clientMsgChan

133 msg <- readChan clientMsgChan

129 case msg of

134 case msg of

@@ -193,12 +198,12 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x

193-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety

198-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety

194-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)

199-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)

195data Message

200data Message

196− = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (Either ResponseError resp))

201+ = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (Either ResponseError resp))

197 -- | Used for cases in which we need to send not only a response,

202 -- | Used for cases in which we need to send not only a response,

198 -- but also an additional request to the client.

203 -- but also an additional request to the client.

199 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.

204 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.

200− | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))

205+ | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))

201− | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())

206+ | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO ())

202

207

203

208

204modifyOptions :: LSP.Options -> LSP.Options

209modifyOptions :: LSP.Options -> LSP.Options

src/Development/IDE/LSP/Notifications.hs+8

@@ -13,6 +13,7 @@ import qualified Language.Haskell.LSP.Core as LSP

13import Language.Haskell.LSP.Types

14import qualified Language.Haskell.LSP.Types as LSP

15

16+import Development.IDE.Core.IdeConfiguration

16import Development.IDE.Core.Service

17import Development.IDE.Core.Service

17import Development.IDE.Types.Location

18import Development.IDE.Types.Location

18import Development.IDE.Types.Logger

19import Development.IDE.Types.Logger

@@ -69,4 +70,11 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

69 logInfo (ideLogger ide) $ "Files created or deleted: " <> msg

70 logInfo (ideLogger ide) $ "Files created or deleted: " <> msg

70 modifyFileExists ide events

71 modifyFileExists ide events

71 setSomethingModified ide

72 setSomethingModified ide

73+ ,LSP.didChangeWorkspaceFoldersNotificationHandler = withNotification (LSP.didChangeWorkspaceFoldersNotificationHandler x) $

74+ \_ ide (DidChangeWorkspaceFoldersParams events) -> do

75+ let add = S.union

76+ substract = flip S.difference

77+ modifyWorkspaceFolders ide

78+ $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events))

79+ . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events))

72 }

80 }

src/Development/IDE/LSP/Outline.hs+2−1

@@ -18,6 +18,7 @@ import Data.Text ( Text

18 )

19import qualified Data.Text as T

20import Development.IDE.Core.Rules

21+import Development.IDE.Core.IdeConfiguration

21import Development.IDE.Core.Shake

22import Development.IDE.Core.Shake

22import Development.IDE.GHC.Compat

23import Development.IDE.GHC.Compat

23import Development.IDE.GHC.Error ( srcSpanToRange )

24import Development.IDE.GHC.Error ( srcSpanToRange )

@@ -34,7 +35,7 @@ setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x

34 }

35 }

35

36

36moduleOutline

37moduleOutline

37− :: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)

38+ :: LSP.LspFuncs IdeConfiguration -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)

38moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }

39moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }

39 = case uriToFilePath uri of

40 = case uriToFilePath uri of

40 Just (toNormalizedFilePath -> fp) -> do

41 Just (toNormalizedFilePath -> fp) -> do

src/Development/IDE/LSP/Server.hs+4−3

@@ -14,22 +14,23 @@ import Data.Default

14import Language.Haskell.LSP.Types

15import qualified Language.Haskell.LSP.Core as LSP

16import qualified Language.Haskell.LSP.Messages as LSP

17+import Development.IDE.Core.IdeConfiguration

17import Development.IDE.Core.Service

18import Development.IDE.Core.Service

18

19

19data WithMessage = WithMessage

20data WithMessage = WithMessage

20 {withResponse :: forall m req resp . (Show m, Show req) =>

21 {withResponse :: forall m req resp . (Show m, Show req) =>

21 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

22 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

22− (LSP.LspFuncs () -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work

23+ (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work

23 Maybe (LSP.Handler (RequestMessage m req resp))

24 Maybe (LSP.Handler (RequestMessage m req resp))

24 ,withNotification :: forall m req . (Show m, Show req) =>

25 ,withNotification :: forall m req . (Show m, Show req) =>

25 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler

26 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler

26− (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work

27+ (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO ()) -> -- actual work

27 Maybe (LSP.Handler (NotificationMessage m req))

28 Maybe (LSP.Handler (NotificationMessage m req))

28 ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.

29 ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.

29 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>

30 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>

30 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

31 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

31 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req

32 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req

32− (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work

33+ (LSP.LspFuncs IdeConfiguration -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work

33 Maybe (LSP.Handler (RequestMessage m req resp))

34 Maybe (LSP.Handler (RequestMessage m req resp))

34 }

35 }

35

36

src/Development/IDE/Plugin.hs+2−1

@@ -7,6 +7,7 @@ import Development.IDE.LSP.Server

7

8import Language.Haskell.LSP.Types

9import Development.IDE.Core.Rules

10+import Development.IDE.Core.IdeConfiguration

10import qualified Language.Haskell.LSP.Core as LSP

11import qualified Language.Haskell.LSP.Core as LSP

11import Language.Haskell.LSP.Messages

12import Language.Haskell.LSP.Messages

12

13

@@ -26,7 +27,7 @@ instance Monoid Plugin where

26 mempty = def

27 mempty = def

27

28

29

29−codeActionPlugin :: (LSP.LspFuncs () -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin

30+codeActionPlugin :: (LSP.LspFuncs IdeConfiguration -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin

30codeActionPlugin f = Plugin mempty $ PartialHandlers $ \WithMessage{..} x -> return x{

31codeActionPlugin f = Plugin mempty $ PartialHandlers $ \WithMessage{..} x -> return x{

31 LSP.codeActionHandler = withResponse RspCodeAction g

32 LSP.codeActionHandler = withResponse RspCodeAction g

32 }

33 }

src/Development/IDE/Plugin/CodeAction.hs+4−3

@@ -12,6 +12,7 @@ import Language.Haskell.LSP.Types

12import Control.Monad (join)

13import Development.IDE.Plugin

14import Development.IDE.GHC.Compat

15+import Development.IDE.Core.IdeConfiguration

15import Development.IDE.Core.Rules

16import Development.IDE.Core.Rules

16import Development.IDE.Core.RuleTypes

17import Development.IDE.Core.RuleTypes

17import Development.IDE.Core.Service

18import Development.IDE.Core.Service

@@ -43,7 +44,7 @@ plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens

43

44

44-- | Generate code actions.

45-- | Generate code actions.

45codeAction

46codeAction

46− :: LSP.LspFuncs ()

47+ :: LSP.LspFuncs IdeConfiguration

47 -> IdeState

48 -> IdeState

48 -> TextDocumentIdentifier

49 -> TextDocumentIdentifier

49 -> Range

50 -> Range

@@ -65,7 +66,7 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag

65

66

66-- | Generate code lenses.

67-- | Generate code lenses.

67codeLens

68codeLens

68− :: LSP.LspFuncs ()

69+ :: LSP.LspFuncs IdeConfiguration

69 -> IdeState

70 -> IdeState

70 -> CodeLensParams

71 -> CodeLensParams

71 -> IO (Either ResponseError (List CodeLens))

72 -> IO (Either ResponseError (List CodeLens))

@@ -86,7 +87,7 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri}

86

87

87-- | Execute the "typesignature.add" command.

88-- | Execute the "typesignature.add" command.

88executeAddSignatureCommand

89executeAddSignatureCommand

89− :: LSP.LspFuncs ()

90+ :: LSP.LspFuncs IdeConfiguration

90 -> IdeState

91 -> IdeState

91 -> ExecuteCommandParams

92 -> ExecuteCommandParams

92 -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

93 -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

src/Development/IDE/Plugin/Completions.hs+2−1

@@ -17,6 +17,7 @@ import Development.IDE.Plugin

17import Development.IDE.Core.Service

18import Development.IDE.Plugin.Completions.Logic

19import Development.IDE.Types.Location

20+import Development.IDE.Core.IdeConfiguration

20import Development.IDE.Core.PositionMapping

21import Development.IDE.Core.PositionMapping

21import Development.IDE.Core.RuleTypes

22import Development.IDE.Core.RuleTypes

22import Development.IDE.Core.Shake

23import Development.IDE.Core.Shake

@@ -55,7 +56,7 @@ instance Binary ProduceCompletions

55

56

56-- | Generate code actions.

57-- | Generate code actions.

57getCompletionsLSP

58getCompletionsLSP

58− :: LSP.LspFuncs ()

59+ :: LSP.LspFuncs IdeConfiguration

59 -> IdeState

60 -> IdeState

60 -> CompletionParams

61 -> CompletionParams

61 -> IO (Either ResponseError CompletionResponseResult)

62 -> IO (Either ResponseError CompletionResponseResult)

test/exe/Main.hs+39−3

@@ -63,6 +63,7 @@ main = defaultMain $ testGroup "HIE"

63 , unitTests

64 , haddockTests

65 , positionMappingTests

66+ , watchedFilesTests

66 ]

67 ]

67

68

68initializeResponseTests :: TestTree

69initializeResponseTests :: TestTree

@@ -99,7 +100,7 @@ initializeResponseTests = withResource acquire release tests where

99 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

100 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

100 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

101 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

101 , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

102 , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

102− , chk "NO workspace" _workspace nothingWorkspace

103+ , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))

103 , chk "NO experimental" _experimental Nothing

104 , chk "NO experimental" _experimental Nothing

104 ] where

105 ] where

105

106

@@ -110,8 +111,6 @@ initializeResponseTests = withResource acquire release tests where

110 , _willSaveWaitUntil = Nothing

111 , _willSaveWaitUntil = Nothing

111 , _save = Just (SaveOptions {_includeText = Nothing})}))

112 , _save = Just (SaveOptions {_includeText = Nothing})}))

112

113

113− nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})

114−

115 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree

114 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree

116 chk title getActual expected =

115 chk title getActual expected =

117 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

116 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

@@ -243,6 +242,16 @@ diagnosticTests = testGroup "diagnostics"

243 let contentA = T.unlines [ "module ModuleA where" ]

242 let contentA = T.unlines [ "module ModuleA where" ]

244 _ <- openDoc' "ModuleA.hs" "haskell" contentA

243 _ <- openDoc' "ModuleA.hs" "haskell" contentA

245 expectDiagnostics [("ModuleB.hs", [])]

244 expectDiagnostics [("ModuleB.hs", [])]

245+ , testSessionWait "add missing module (non workspace)" $ do

246+ let contentB = T.unlines

247+ [ "module ModuleB where"

248+ , "import ModuleA"

249+ ]

250+ _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB

251+ expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

252+ let contentA = T.unlines [ "module ModuleA where" ]

253+ _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA

254+ expectDiagnostics [("/tmp/ModuleB.hs", [])]

246 , testSessionWait "cyclic module dependency" $ do

255 , testSessionWait "cyclic module dependency" $ do

247 let contentA = T.unlines

256 let contentA = T.unlines

248 [ "module ModuleA where"

257 [ "module ModuleA where"

@@ -415,6 +424,26 @@ codeLensesTests = testGroup "code lenses"

415 [ addSigLensesTests

424 [ addSigLensesTests

416 ]

425 ]

417

426

427+watchedFilesTests :: TestTree

428+watchedFilesTests = testGroup "watched files"

429+ [ testSession "workspace file" $ do

430+ _ <- openDoc' "A.hs" "haskell" "module A where"

431+ RequestMessage{_params = RegistrationParams (List regs)} <- skipManyTill anyMessage (message @RegisterCapabilityRequest)

432+ let watchedFileRegs =

433+ [ args | Registration _id WorkspaceDidChangeWatchedFiles args <- regs ]

434+ liftIO $ assertBool "watches workspace files" $ not $ null watchedFileRegs

435+ , testSession "non workspace file" $ do

436+ _ <- openDoc' "/tmp/A.hs" "haskell" "module A where"

437+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)

438+ let watchedFileRegs =

439+ [ args

440+ | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs

441+ , Registration _id WorkspaceDidChangeWatchedFiles args <- regs

442+ ]

443+ liftIO $ watchedFileRegs @?= []

444+ -- TODO add a test for didChangeWorkspaceFolder

445+ ]

446+

418renameActionTests :: TestTree

447renameActionTests :: TestTree

419renameActionTests = testGroup "rename actions"

448renameActionTests = testGroup "rename actions"

420 [ testSession "change to local variable name" $ do

449 [ testSession "change to local variable name" $ do

@@ -1812,9 +1841,16 @@ unitTests = do

1812openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

1841openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

1813openDoc' fp name contents = do

1842openDoc' fp name contents = do

1814 res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents

1843 res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents

1844+ -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them

1815 sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])

1845 sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])

1816 return res

1846 return res

1817

1847

1848+-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace

1849+openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

1850+-- At the moment this is just LSPTest.openDoc' but it may change in the future

1851+-- when/if lsp-test implements WatchedFiles

1852+openDoc'' = LSPTest.openDoc'

1853+

1818positionMappingTests :: TestTree

1854positionMappingTests :: TestTree

1819positionMappingTests =

1855positionMappingTests =

1820 testGroup "position mapping"

1856 testGroup "position mapping"