Skip to content

Commit 61d9df9

Browse files
July541July541
committed
Merge branch 'master' of https://github.com/haskell/haskell-language-server into call-hierarchy
2 parents fd11a10 + 9207050 commit 61d9df9

23 files changed

+222
-48
lines changed

‎.circleci/config.yml

+5-5
Original file line numberDiff line numberDiff line change
@@ -18,9 +18,9 @@ defaults: &defaults
1818

1919
- restore_cache:
2020
keys:
21-
- stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "stack-build.txt" }}-{{ checksum "all-cabal.txt" }}
22-
- stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "stack-build.txt" }}
23-
- stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "resolver.txt" }}
21+
- v2-stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "stack-build.txt" }}-{{ checksum "all-cabal.txt" }}
22+
- v2-stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "stack-build.txt" }}
23+
- v2-stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "resolver.txt" }}
2424

2525
- run:
2626
name: Stack upgrade
@@ -46,7 +46,7 @@ defaults: &defaults
4646
destination: bin
4747

4848
- save_cache:
49-
key: stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "resolver.txt" }}
49+
key: v2-stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "resolver.txt" }}
5050
paths: &cache_paths
5151
- ~/.stack
5252
- ~/build/.stack-work
@@ -58,7 +58,7 @@ defaults: &defaults
5858
no_output_timeout: 120m
5959

6060
- save_cache:
61-
key: stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "stack-build.txt" }}-{{ checksum "all-cabal.txt" }}
61+
key: v2-stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "stack-build.txt" }}-{{ checksum "all-cabal.txt" }}
6262
paths: *cache_paths
6363

6464
version: 2

‎flake.lock

+3-3
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎flake.nix

+23-4
Original file line numberDiff line numberDiff line change
@@ -71,10 +71,6 @@
7171
tweaks = hself: hsuper:
7272
with haskell.lib; {
7373

74-
hls-tactics-plugin = hsuper.hls-tactics-plugin.override {
75-
refinery = hself.refinery_0_3_0_0;
76-
};
77-
7874
hiedb = hself.callCabal2nix "hiedb"
7975
(builtins.fetchTarball {
8076
url =
@@ -83,6 +79,29 @@
8379
"13jz8c46zfpf54ya2wsv4akhn0wcfc6qjazqsjfir5gpvsi7v8xr";
8480
}) { };
8581

82+
implicit-hie = hself.callCabal2nix "implicit-hie"
83+
(builtins.fetchTarball {
84+
url =
85+
"https://hackage.haskell.org/package/implicit-hie-0.1.2.6/implicit-hie-0.1.2.6.tar.gz";
86+
sha256 =
87+
"067bmw5b9qg55ggklbfyf93jgpkbzmprmgv906jscfzvv1h8266c";
88+
}) { };
89+
90+
implicit-hie-cradle = hself.callCabal2nix "implicit-hie-cradle"
91+
(builtins.fetchTarball {
92+
url =
93+
"https://hackage.haskell.org/package/implicit-hie-cradle-0.3.0.5/implicit-hie-cradle-0.3.0.5.tar.gz";
94+
sha256 =
95+
"15a7g9x6cjk2b92hb2wilxx4550msxp1pmk5a2shiva821qaxnfq";
96+
}) { };
97+
98+
ghc-source-gen = hself.callCabal2nix "ghc-source-gen"
99+
(builtins.fetchTarball {
100+
url =
101+
"https://hackage.haskell.org/package/ghc-source-gen-0.4.1.0/ghc-source-gen-0.4.1.0.tar.gz";
102+
sha256 =
103+
"0kk599vk54ckikpxkzwrbx7z5x0xr20hr179rldmnlb34bf9mpnk";
104+
}) { };
86105
};
87106

88107
hlsSources =

‎ghcide/bench/config.yaml

+1
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ experiments:
4848
- "code actions after edit"
4949
- "code actions after cradle edit"
5050
- "documentSymbols after edit"
51+
- "hole fit suggestions"
5152

5253
# An ordered list of versions to analyze
5354
versions:

‎ghcide/bench/lib/Experiments.hs

+31
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ import Data.Maybe
3131
import qualified Data.Text as T
3232
import Data.Version
3333
import Development.IDE.Plugin.Test
34+
import Development.IDE.Test.Diagnostic
3435
import Development.Shake (CmdOption (Cwd, FileStdout),
3536
cmd_)
3637
import Experiments.Types
@@ -169,6 +170,36 @@ experiments =
169170
sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
170171
List [ FileEvent (filePathToUri "hie.yaml") FcChanged ]
171172
flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP)
173+
),
174+
---------------------------------------------------------------------------------------
175+
benchWithSetup
176+
"hole fit suggestions"
177+
( mapM_ $ \DocumentPositions{..} -> do
178+
let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent
179+
{ _range = Just Range {_start = bottom, _end = bottom}
180+
, _rangeLength = Nothing, _text = t}
181+
bottom = Position maxBound 0
182+
t = T.unlines
183+
[""
184+
,"holef :: [Int] -> [Int]"
185+
,"holef = _"
186+
,""
187+
,"holeg :: [()] -> [()]"
188+
,"holeg = _"
189+
]
190+
changeDoc doc [edit]
191+
)
192+
(\docs -> do
193+
forM_ docs $ \DocumentPositions{..} ->
194+
changeDoc doc [charEdit stringLiteralP]
195+
void waitForDiagnostics
196+
waitForProgressDone
197+
flip allM docs $ \DocumentPositions{..} -> do
198+
bottom <- pred . length . T.lines <$> documentContents doc
199+
diags <- getCurrentDiagnostics doc
200+
case requireDiagnostic diags (DsError, (bottom, 8), "Found hole", Nothing) of
201+
Nothing -> pure True
202+
Just _err -> pure False
172203
)
173204
]
174205

‎ghcide/ghcide.cabal

+5-1
Original file line numberDiff line numberDiff line change
@@ -370,6 +370,7 @@ test-suite ghcide-tests
370370
main-is: Main.hs
371371
other-modules:
372372
Development.IDE.Test
373+
Development.IDE.Test.Diagnostic
373374
Development.IDE.Test.Runfiles
374375
Experiments
375376
Experiments.Types
@@ -403,17 +404,20 @@ executable ghcide-bench
403404
extra,
404405
filepath,
405406
ghcide,
407+
lens,
406408
lsp-test,
409+
lsp-types,
407410
optparse-applicative,
408411
process,
409412
safe-exceptions,
410413
hls-graph,
411414
shake,
412415
text
413-
hs-source-dirs: bench/lib bench/exe
416+
hs-source-dirs: bench/lib bench/exe test/src
414417
ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts
415418
main-is: Main.hs
416419
other-modules:
420+
Development.IDE.Test.Diagnostic
417421
Experiments
418422
Experiments.Types
419423
default-extensions:

‎ghcide/test/exe/Main.hs

+1
Original file line numberDiff line numberDiff line change
@@ -5138,6 +5138,7 @@ benchmarkTests =
51385138
assertBool "did not successfully complete 5 repetitions" $ Bench.success res
51395139
| e <- Bench.experiments
51405140
, Bench.name e /= "edit" -- the edit experiment does not ever fail
5141+
, Bench.name e /= "hole fit suggestions" -- is too slow!
51415142
-- the cradle experiments are way too slow
51425143
, not ("cradle" `isInfixOf` Bench.name e)
51435144
]

‎ghcide/test/src/Development/IDE/Test.hs

+10-34
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ import Data.Maybe (fromJust)
3333
import qualified Data.Text as T
3434
import Development.IDE.Plugin.Test (TestRequest (..),
3535
WaitForIdeRuleResult)
36+
import Development.IDE.Test.Diagnostic
3637
import Language.LSP.Test hiding (message)
3738
import qualified Language.LSP.Test as LspTest
3839
import Language.LSP.Types
@@ -41,31 +42,14 @@ import System.Directory (canonicalizePath)
4142
import System.Time.Extra
4243
import Test.Tasty.HUnit
4344

44-
-- | (0-based line number, 0-based column number)
45-
type Cursor = (Int, Int)
46-
47-
cursorPosition :: Cursor -> Position
48-
cursorPosition (line, col) = Position line col
49-
50-
requireDiagnostic :: HasCallStack => List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion
51-
requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) = do
52-
unless (any match actuals) $
53-
assertFailure $
54-
"Could not find " <> show expected <>
55-
" in " <> show actuals
56-
where
57-
match :: Diagnostic -> Bool
58-
match d =
59-
Just severity == _severity d
60-
&& cursorPosition cursor == d ^. range . start
61-
&& standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf`
62-
standardizeQuotes (T.toLower $ d ^. message)
63-
&& hasTag expectedTag (d ^. tags)
64-
65-
hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool
66-
hasTag Nothing _ = True
67-
hasTag (Just _) Nothing = False
68-
hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags
45+
requireDiagnosticM
46+
:: (Foldable f, Show (f Diagnostic), HasCallStack)
47+
=> f Diagnostic
48+
-> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)
49+
-> Assertion
50+
requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of
51+
Nothing -> pure ()
52+
Just err -> assertFailure err
6953

7054
-- |wait for @timeout@ seconds and report an assertion failure
7155
-- if any diagnostic messages arrive in that period
@@ -154,7 +138,7 @@ expectDiagnosticsWithTags' next expected = go expected
154138
<> " got "
155139
<> show actual
156140
Just expected -> do
157-
liftIO $ mapM_ (requireDiagnostic actual) expected
141+
liftIO $ mapM_ (requireDiagnosticM actual) expected
158142
liftIO $
159143
unless (length expected == length actual) $
160144
assertFailure $
@@ -182,14 +166,6 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat
182166
diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)
183167
diagnostic = LspTest.message STextDocumentPublishDiagnostics
184168

185-
standardizeQuotes :: T.Text -> T.Text
186-
standardizeQuotes msg = let
187-
repl '‘' = '\''
188-
repl '’' = '\''
189-
repl '`' = '\''
190-
repl c = c
191-
in T.map repl msg
192-
193169
waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)
194170
waitForAction key TextDocumentIdentifier{_uri} = do
195171
let cm = SCustomMethod "test"

‎ghcide/test/src/Development/IDE/Test/Diagnostic.hs

+47
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
module Development.IDE.Test.Diagnostic where
2+
3+
import Control.Lens ((^.))
4+
import qualified Data.Text as T
5+
import GHC.Stack (HasCallStack)
6+
import Language.LSP.Types
7+
import Language.LSP.Types.Lens as Lsp
8+
9+
-- | (0-based line number, 0-based column number)
10+
type Cursor = (Int, Int)
11+
12+
cursorPosition :: Cursor -> Position
13+
cursorPosition (line, col) = Position line col
14+
15+
type ErrorMsg = String
16+
17+
requireDiagnostic
18+
:: (Foldable f, Show (f Diagnostic), HasCallStack)
19+
=> f Diagnostic
20+
-> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)
21+
-> Maybe ErrorMsg
22+
requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag)
23+
| any match actuals = Nothing
24+
| otherwise = Just $
25+
"Could not find " <> show expected <>
26+
" in " <> show actuals
27+
where
28+
match :: Diagnostic -> Bool
29+
match d =
30+
Just severity == _severity d
31+
&& cursorPosition cursor == d ^. range . start
32+
&& standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf`
33+
standardizeQuotes (T.toLower $ d ^. message)
34+
&& hasTag expectedTag (d ^. tags)
35+
36+
hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool
37+
hasTag Nothing _ = True
38+
hasTag (Just _) Nothing = False
39+
hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags
40+
41+
standardizeQuotes :: T.Text -> T.Text
42+
standardizeQuotes msg = let
43+
repl '‘' = '\''
44+
repl '’' = '\''
45+
repl '`' = '\''
46+
repl c = c
47+
in T.map repl msg

‎hls-test-utils/src/Test/Hls/Util.hs

+14
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module Test.Hls.Util
1010
(
1111
codeActionSupportCaps
1212
, expectCodeAction
13+
, dontExpectCodeAction
1314
, expectDiagnostic
1415
, expectNoMoreDiagnostics
1516
, expectSameLocations
@@ -45,6 +46,7 @@ import Control.Lens ((^.))
4546
import Control.Monad
4647
import Control.Monad.IO.Class
4748
import qualified Data.Aeson as A
49+
import Data.Bool (bool)
4850
import Data.Default
4951
import Data.List (intercalate)
5052
import Data.List.Extra (find)
@@ -315,6 +317,10 @@ fromCommand _ = error "Not a command"
315317
onMatch :: [a] -> (a -> Bool) -> String -> IO a
316318
onMatch as predicate err = maybe (fail err) return (find predicate as)
317319

320+
noMatch :: [a] -> (a -> Bool) -> String -> IO ()
321+
noMatch [] _ _ = pure ()
322+
noMatch as predicate err = bool (pure ()) (fail err) (any predicate as)
323+
318324
inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic
319325
inspectDiagnostic diags s = onMatch diags (\ca -> all (`T.isInfixOf` (ca ^. L.message)) s) err
320326
where err = "expected diagnostic matching '" ++ show s ++ "' but did not find one"
@@ -331,6 +337,14 @@ inspectCodeAction cars s = fromAction <$> onMatch cars predicate err
331337
expectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO ()
332338
expectCodeAction cars s = void $ inspectCodeAction cars s
333339

340+
dontExpectCodeAction :: [Command |? CodeAction] -> [T.Text] -> IO ()
341+
dontExpectCodeAction cars s =
342+
noMatch cars predicate err
343+
where predicate (InR ca) = all (`T.isInfixOf` (ca ^. L.title)) s
344+
predicate _ = False
345+
err = "didn't expected code action matching '" ++ show s ++ "' but found one anyway"
346+
347+
334348
inspectCommand :: [Command |? CodeAction] -> [T.Text] -> IO Command
335349
inspectCommand cars s = fromCommand <$> onMatch cars predicate err
336350
where predicate (InL command) = all (`T.isInfixOf` (command ^. L.title)) s

‎plugins/hls-tactics-plugin/README.md

+11
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,17 @@ fill hole" code action, *et voila!*
3434
[hls]: https://github.com/haskell/haskell-language-server/releases
3535

3636

37+
## Usage
38+
39+
When enabled, Wingman for Haskell will remove HLS support for hole-fit code
40+
actions. These code actions are provided by GHC and make typechecking extremely
41+
slow in the presence of typed holes. Because Wingman relies so heavily on typed
42+
holes, these features are in great tension.
43+
44+
The solution: we just remove the hole-fit actions. If you'd prefer to use these
45+
actions, you can get them back by compiling HLS without the Wingman plugin.
46+
47+
3748
## Editor Configuration
3849

3950
### Enabling Jump to Hole

‎plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs

+9-1
Original file line numberDiff line numberDiff line change
@@ -19,9 +19,17 @@ staticPlugin :: DynFlagsModifications
1919
staticPlugin = mempty
2020
{ dynFlagsModifyGlobal =
2121
\df -> allowEmptyCaseButWithWarning
22+
$ flip gopt_unset Opt_SortBySubsumHoleFits
23+
$ flip gopt_unset Opt_ShowValidHoleFits
2224
$ df
25+
{ refLevelHoleFits = Just 0
26+
, maxRefHoleFits = Just 0
27+
, maxValidHoleFits = Just 0
28+
#if __GLASGOW_HASKELL__ >= 808
29+
, staticPlugins = staticPlugins df <> [metaprogrammingPlugin]
30+
#endif
31+
}
2332
#if __GLASGOW_HASKELL__ >= 808
24-
{ staticPlugins = staticPlugins df <> [metaprogrammingPlugin] }
2533
, dynFlagsModifyParser = enableQuasiQuotes
2634
#endif
2735
}

‎stack-8.10.2.yaml

+2
Original file line numberDiff line numberDiff line change
@@ -75,6 +75,8 @@ extra-deps:
7575
# https://github.com/haskell/lsp/pull/332
7676

7777
configure-options:
78+
$targets:
79+
- --enable-executable-dynamic
7880
ghcide:
7981
- --disable-library-for-ghci
8082
haskell-language-server:

‎stack-8.10.3.yaml

+2
Original file line numberDiff line numberDiff line change
@@ -75,6 +75,8 @@ extra-deps:
7575
# https://github.com/haskell/lsp/pull/332
7676

7777
configure-options:
78+
$targets:
79+
- --enable-executable-dynamic
7880
ghcide:
7981
- --disable-library-for-ghci
8082
haskell-language-server:

0 commit comments

Comments
 (0)