Skip to content

Commit df6cc3c

Browse files
July541July541
authored
Expand input to pragma if available (#2871)
1 parent 6802aaf commit df6cc3c

File tree

6 files changed

+105
-100
lines changed

6 files changed

+105
-100
lines changed

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

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -47,8 +47,8 @@ import Data.Aeson (Result (Success),
4747
import qualified Data.Aeson as A
4848
import Data.ByteString.Lazy (ByteString)
4949
import Data.Default (def)
50-
import Data.Maybe (fromMaybe)
5150
import qualified Data.Map as M
51+
import Data.Maybe (fromMaybe)
5252
import qualified Data.Text as T
5353
import qualified Data.Text.Lazy as TL
5454
import qualified Data.Text.Lazy.Encoding as TL
@@ -69,7 +69,8 @@ import Development.IDE.Types.Logger (Logger (Logger),
6969
import Development.IDE.Types.Options
7070
import GHC.IO.Handle
7171
import GHC.Stack (emptyCallStack)
72-
import Ide.Plugin.Config (Config, formattingProvider, PluginConfig, plugins)
72+
import Ide.Plugin.Config (Config, PluginConfig,
73+
formattingProvider, plugins)
7374
import Ide.PluginUtils (idePluginsToPluginDesc,
7475
pluginDescToIdePlugins)
7576
import Ide.Types
@@ -208,9 +209,9 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre
208209
arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger
209210

210211
hlsPlugins =
211-
idePluginsToPluginDesc argsHlsPlugins
212+
plugins
212213
++ [Test.blockCommandDescriptor "block-command", Test.plugin]
213-
++ plugins
214+
++ idePluginsToPluginDesc argsHlsPlugins
214215
ideOptions = \config ghcSession ->
215216
let defIdeOptions = argsIdeOptions config ghcSession
216217
in defIdeOptions

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

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ module Test.Hls.Util
3232
, knownBrokenOnWindows
3333
, knownBrokenForGhcVersions
3434
, knownBrokenInEnv
35+
, onlyWorkForGhcVersions
3536
, setupBuildToolFiles
3637
, SymbolLocation
3738
, waitForDiagnosticsFrom
@@ -149,6 +150,14 @@ ignoreInEnv envSpecs reason
149150
ignoreForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
150151
ignoreForGhcVersions vers = ignoreInEnv (map GhcVer vers)
151152

153+
-- | Mark as broken if GHC does not match only work versions.
154+
onlyWorkForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
155+
onlyWorkForGhcVersions vers reason =
156+
if ghcVersion `elem` vers
157+
then id
158+
else expectFailBecause reason
159+
160+
-- | Ignore the test if GHC does not match only work versions.
152161
onlyRunForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree
153162
onlyRunForGhcVersions vers =
154163
if ghcVersion `elem` vers

‎plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,7 @@ library
3333
, transformers
3434
, unordered-containers
3535
, containers
36-
36+
ghc-options: -Wall -Wno-name-shadowing
3737
default-language: Haskell2010
3838

3939
test-suite tests

‎plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs

Lines changed: 67 additions & 87 deletions
Original file line numberDiff line numberDiff line change
@@ -10,55 +10,25 @@
1010
-- | Provides code actions to add missing pragmas (whenever GHC suggests to)
1111
module Ide.Plugin.Pragmas
1212
( descriptor
13+
-- For testing
14+
, validPragmas
1315
) where
1416

15-
import Control.Applicative ((<|>))
16-
import Control.Lens hiding (List)
17-
import Control.Monad (join)
18-
import Control.Monad.IO.Class (MonadIO (liftIO))
19-
import Control.Monad.Trans.State.Strict (State)
20-
import Data.Bits (Bits (bit, complement, setBit, (.&.)))
21-
import Data.Char (isSpace)
22-
import qualified Data.Char as Char
23-
import Data.Coerce (coerce)
24-
import Data.Functor (void, ($>))
25-
import qualified Data.HashMap.Strict as H
26-
import qualified Data.List as List
27-
import Data.List.Extra (nubOrdOn)
28-
import qualified Data.Map.Strict as Map
29-
import Data.Maybe (catMaybes, listToMaybe,
30-
mapMaybe)
31-
import qualified Data.Maybe as Maybe
32-
import Data.Ord (Down (Down))
33-
import Data.Semigroup (Semigroup ((<>)))
34-
import qualified Data.Text as T
35-
import Data.Word (Word64)
36-
import Development.IDE as D (Diagnostic (Diagnostic, _code, _message),
37-
GhcSession (GhcSession),
38-
HscEnvEq (hscEnv),
39-
IdeState, List (List),
40-
ParseResult (POk),
41-
Position (Position),
42-
Range (Range), Uri,
43-
getFileContents,
44-
getParsedModule,
45-
printOutputable, runAction,
46-
srcSpanToRange,
47-
toNormalizedUri,
48-
uriToFilePath',
49-
useWithStale)
17+
import Control.Lens hiding (List)
18+
import Control.Monad.IO.Class (MonadIO (liftIO))
19+
import qualified Data.HashMap.Strict as H
20+
import Data.List.Extra (nubOrdOn)
21+
import Data.Maybe (catMaybes)
22+
import qualified Data.Text as T
23+
import Development.IDE
5024
import Development.IDE.GHC.Compat
51-
import Development.IDE.GHC.Compat.Util (StringBuffer, atEnd,
52-
nextChar,
53-
stringToStringBuffer)
54-
import qualified Development.IDE.Spans.Pragmas as Pragmas
55-
import Development.IDE.Types.HscEnvEq (HscEnvEq, hscEnv)
25+
import qualified Development.IDE.Spans.Pragmas as Pragmas
5626
import Ide.Types
57-
import qualified Language.LSP.Server as LSP
58-
import qualified Language.LSP.Types as J
59-
import qualified Language.LSP.Types.Lens as J
60-
import qualified Language.LSP.VFS as VFS
61-
import qualified Text.Fuzzy as Fuzzy
27+
import qualified Language.LSP.Server as LSP
28+
import qualified Language.LSP.Types as J
29+
import qualified Language.LSP.Types.Lens as J
30+
import qualified Language.LSP.VFS as VFS
31+
import qualified Text.Fuzzy as Fuzzy
6232

6333
-- ---------------------------------------------------------------------
6434

@@ -193,7 +163,9 @@ allPragmas =
193163
-- Language Version Extensions
194164
, "Haskell98"
195165
, "Haskell2010"
196-
-- Maybe, GHC 2021 after its release?
166+
#if MIN_VERSION_ghc(9,2,0)
167+
, "GHC2021"
168+
#endif
197169
]
198170

199171
-- ---------------------------------------------------------------------
@@ -214,59 +186,67 @@ completion _ide _ complParams = do
214186
= J.List $ map buildCompletion
215187
(Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas)
216188
| "{-# options_ghc" `T.isPrefixOf` line
217-
= J.List $ map mkExtCompl
189+
= J.List $ map buildCompletion
218190
(Fuzzy.simpleFilter (VFS.prefixText pfix) flags)
219191
| "{-#" `T.isPrefixOf` line
220-
= J.List $ map (\(a, b, c) -> mkPragmaCompl (a <> suffix) b c) validPragmas
192+
= J.List $ [ mkPragmaCompl (a <> suffix) b c
193+
| (a, b, c, w) <- validPragmas, w == NewLine ]
221194
| otherwise
222-
= J.List []
195+
= J.List $ [ mkPragmaCompl (prefix <> a <> suffix) b c
196+
| (a, b, c, _) <- validPragmas, Fuzzy.test word b]
223197
where
224198
line = T.toLower $ VFS.fullLine pfix
199+
word = VFS.prefixText pfix
200+
-- Not completely correct, may fail if more than one "{-#" exist
201+
-- , we can ignore it since it rarely happen.
202+
prefix
203+
| "{-# " `T.isInfixOf` line = ""
204+
| "{-#" `T.isInfixOf` line = " "
205+
| otherwise = "{-# "
225206
suffix
226-
| "#-}" `T.isSuffixOf` line = " "
227-
| "-}" `T.isSuffixOf` line = " #"
228-
| "}" `T.isSuffixOf` line = " #-"
207+
| " #-}" `T.isSuffixOf` line = ""
208+
| "#-}" `T.isSuffixOf` line = " "
209+
| "-}" `T.isSuffixOf` line = " #"
210+
| "}" `T.isSuffixOf` line = " #-"
229211
| otherwise = " #-}"
230212
result Nothing = J.List []
231-
buildCompletion p =
232-
J.CompletionItem
233-
{ _label = p,
234-
_kind = Just J.CiKeyword,
235-
_tags = Nothing,
236-
_detail = Nothing,
237-
_documentation = Nothing,
238-
_deprecated = Nothing,
239-
_preselect = Nothing,
240-
_sortText = Nothing,
241-
_filterText = Nothing,
242-
_insertText = Nothing,
243-
_insertTextFormat = Nothing,
244-
_insertTextMode = Nothing,
245-
_textEdit = Nothing,
246-
_additionalTextEdits = Nothing,
247-
_commitCharacters = Nothing,
248-
_command = Nothing,
249-
_xdata = Nothing
250-
}
251213
_ -> return $ J.List []
252214

253215
-----------------------------------------------------------------------
254-
validPragmas :: [(T.Text, T.Text, T.Text)]
216+
217+
-- | Pragma where exist
218+
data AppearWhere =
219+
NewLine
220+
-- ^Must be on a new line
221+
| CanInline
222+
-- ^Can appear in the line
223+
deriving (Show, Eq)
224+
225+
validPragmas :: [(T.Text, T.Text, T.Text, AppearWhere)]
255226
validPragmas =
256-
[ ("LANGUAGE ${1:extension}" , "LANGUAGE", "{-# LANGUAGE #-}")
257-
, ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC", "{-# OPTIONS_GHC #-}")
258-
, ("INLINE ${1:function}" , "INLINE", "{-# INLINE #-}")
259-
, ("NOINLINE ${1:function}" , "NOINLINE", "{-# NOINLINE #-}")
260-
, ("INLINABLE ${1:function}" , "INLINABLE", "{-# INLINABLE #-}")
261-
, ("WARNING ${1:message}" , "WARNING", "{-# WARNING #-}")
262-
, ("DEPRECATED ${1:message}" , "DEPRECATED", "{-# DEPRECATED #-}")
263-
, ("ANN ${1:annotation}" , "ANN", "{-# ANN #-}")
264-
, ("RULES" , "RULES", "{-# RULES #-}")
265-
, ("SPECIALIZE ${1:function}" , "SPECIALIZE", "{-# SPECIALIZE #-}")
266-
, ("SPECIALIZE INLINE ${1:function}" , "SPECIALIZE INLINE", "{-# SPECIALIZE INLINE #-}")
227+
[ ("LANGUAGE ${1:extension}" , "LANGUAGE" , "{-# LANGUAGE #-}" , NewLine)
228+
, ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC" , "{-# OPTIONS_GHC #-}" , NewLine)
229+
, ("INLINE ${1:function}" , "INLINE" , "{-# INLINE #-}" , NewLine)
230+
, ("NOINLINE ${1:function}" , "NOINLINE" , "{-# NOINLINE #-}" , NewLine)
231+
, ("INLINABLE ${1:function}" , "INLINABLE" , "{-# INLINABLE #-}" , NewLine)
232+
, ("WARNING ${1:message}" , "WARNING" , "{-# WARNING #-}" , CanInline)
233+
, ("DEPRECATED ${1:message}" , "DEPRECATED" , "{-# DEPRECATED #-}" , CanInline)
234+
, ("ANN ${1:annotation}" , "ANN" , "{-# ANN #-}" , NewLine)
235+
, ("RULES" , "RULES" , "{-# RULES #-}" , NewLine)
236+
, ("SPECIALIZE ${1:function}" , "SPECIALIZE" , "{-# SPECIALIZE #-}" , NewLine)
237+
, ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE", "{-# SPECIALIZE INLINE #-}", NewLine)
238+
, ("SPECIALISE ${1:function}" , "SPECIALISE" , "{-# SPECIALISE #-}" , NewLine)
239+
, ("SPECIALISE INLINE ${1:function}", "SPECIALISE INLINE", "{-# SPECIALISE INLINE #-}", NewLine)
240+
, ("MINIMAL ${1:functions}" , "MINIMAL" , "{-# MINIMAL #-}" , CanInline)
241+
, ("UNPACK" , "UNPACK" , "{-# UNPACK #-}" , CanInline)
242+
, ("NOUNPACK" , "NOUNPACK" , "{-# NOUNPACK #-}" , CanInline)
243+
, ("COMPLETE ${1:function}" , "COMPLETE" , "{-# COMPLETE #-}" , NewLine)
244+
, ("OVERLAPPING" , "OVERLAPPING" , "{-# OVERLAPPING #-}" , CanInline)
245+
, ("OVERLAPPABLE" , "OVERLAPPABLE" , "{-# OVERLAPPABLE #-}" , CanInline)
246+
, ("OVERLAPS" , "OVERLAPS" , "{-# OVERLAPS #-}" , CanInline)
247+
, ("INCOHERENT" , "INCOHERENT" , "{-# INCOHERENT #-}" , CanInline)
267248
]
268249

269-
270250
mkPragmaCompl :: T.Text -> T.Text -> T.Text -> J.CompletionItem
271251
mkPragmaCompl insertText label detail =
272252
J.CompletionItem label (Just J.CiKeyword) Nothing (Just detail)
@@ -281,8 +261,8 @@ stripLeading c (s:ss)
281261
| otherwise = s:ss
282262

283263

284-
mkExtCompl :: T.Text -> J.CompletionItem
285-
mkExtCompl label =
264+
buildCompletion :: T.Text -> J.CompletionItem
265+
buildCompletion label =
286266
J.CompletionItem label (Just J.CiKeyword) Nothing Nothing
287267
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
288268
Nothing Nothing Nothing Nothing Nothing Nothing

‎plugins/hls-pragmas-plugin/test/Main.hs

Lines changed: 21 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,28 +1,30 @@
11
{-# LANGUAGE OverloadedStrings #-}
2+
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
23
module Main
34
( main
45
) where
56

6-
import Control.Lens ((^.), (^..), traversed)
7-
import Data.Foldable (find)
7+
import Control.Lens ((<&>), (^.))
88
import qualified Data.Text as T
9-
import qualified Ide.Plugin.Pragmas as Pragmas
9+
import Ide.Plugin.Pragmas
1010
import qualified Language.LSP.Types.Lens as L
1111
import System.FilePath
1212
import Test.Hls
13+
import Test.Hls.Util (onlyWorkForGhcVersions)
1314

1415
main :: IO ()
1516
main = defaultTestRunner tests
1617

1718
pragmasPlugin :: PluginDescriptor IdeState
18-
pragmasPlugin = Pragmas.descriptor "pragmas"
19+
pragmasPlugin = descriptor "pragmas"
1920

2021
tests :: TestTree
2122
tests =
2223
testGroup "pragmas"
2324
[ codeActionTests
2425
, codeActionTests'
2526
, completionTests
27+
, completionSnippetTests
2628
]
2729

2830
codeActionTests :: TestTree
@@ -77,7 +79,7 @@ codeActionTest testComment fp actions =
7779
mapM_ (\(action, contains) -> go action contains cas) actions
7880
action <- case cas of
7981
(a:_) -> pure a
80-
[] -> liftIO $ assertFailure "Expected non-empty list of code actions"
82+
[] -> liftIO $ assertFailure "Expected non-empty list of code actions"
8183
executeCodeAction action
8284
where
8385
go action contains cas = liftIO $ action `elem` map (^. L.title) cas @? contains
@@ -105,7 +107,7 @@ completionTests :: TestTree
105107
completionTests =
106108
testGroup "completions"
107109
[ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 34, 0, 4]
108-
, completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} ") (Just "{-# LANGUAGE #-}") [0, 4, 0, 31, 0, 4]
110+
, completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 31, 0, 4]
109111
, completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") [0, 4, 0, 32, 0, 4]
110112
, completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") [0, 4, 0, 33, 0, 4]
111113
, completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") [0, 4, 0, 34, 0, 4]
@@ -114,8 +116,21 @@ completionTests =
114116
, completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing [0, 4, 0, 34, 0, 24]
115117
, completionTest "completes the Strict language extension" "Completion.hs" "Str" "Strict" Nothing Nothing Nothing [0, 13, 0, 31, 0, 16]
116118
, completionTest "completes No- language extensions" "Completion.hs" "NoOverload" "NoOverloadedStrings" Nothing Nothing Nothing [0, 13, 0, 31, 0, 23]
119+
, onlyWorkForGhcVersions [GHC92] "GHC2021 flag introduced since ghc9.2" $
120+
completionTest "completes GHC2021 extensions" "Completion.hs" "ghc" "GHC2021" Nothing Nothing Nothing [0, 13, 0, 31, 0, 16]
117121
]
118122

123+
completionSnippetTests :: TestTree
124+
completionSnippetTests =
125+
testGroup "expand snippet to pragma" $
126+
validPragmas <&>
127+
(\(insertText, label, detail, _) ->
128+
let input = T.toLower $ T.init label
129+
in completionTest (T.unpack label)
130+
"Completion.hs" input label (Just Snippet)
131+
(Just $ "{-# " <> insertText <> " #-}") (Just detail)
132+
[0, 0, 0, 34, 0, fromIntegral $ T.length input])
133+
119134
completionTest :: String -> String -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [UInt] -> TestTree
120135
completionTest testComment fileName te' label textFormat insertText detail [a, b, c, d, x, y] =
121136
testCase testComment $ runSessionWithServer pragmasPlugin testDataDir $ do

‎test/functional/Completion.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -138,10 +138,10 @@ tests = testGroup "completions" [
138138
, testCase "import second function completion" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
139139
doc <- openDoc "FunctionCompletions.hs" "haskell"
140140

141-
let te = TextEdit (Range (Position 0 41) (Position 0 42)) ", l"
141+
let te = TextEdit (Range (Position 0 39) (Position 0 39)) ", l"
142142
_ <- applyEdit doc te
143143

144-
compls <- getCompletions doc (Position 0 41)
144+
compls <- getCompletions doc (Position 0 42)
145145
item <- getCompletionByLabel "liftA" compls
146146
liftIO $ do
147147
item ^. label @?= "liftA"

0 commit comments

Comments
 (0)