Skip to content

Commit d498988

Browse files
crtschincrtschin
committed
Isolate export-plugin tests in per-test temp projects
1 parent 0a64bc0 commit d498988

2 files changed

Lines changed: 45 additions & 121 deletions

File tree

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

Lines changed: 45 additions & 106 deletions
Original file line numberDiff line numberDiff line change
@@ -9,19 +9,26 @@ import Ide.Plugin.Export (descriptor)
99
import qualified Language.LSP.Protocol.Lens as L
1010
import System.FilePath ((</>))
1111
import Test.Hls
12+
import Test.Hls.FileSystem (directProject, mkVirtualFileTree)
1213

1314
plugin :: PluginTestDescriptor ()
1415
plugin = mkPluginTestDescriptor' descriptor "export"
1516

1617
testDataDir :: FilePath
1718
testDataDir = "plugins" </> "hls-export-plugin" </> "test" </> "testdata"
1819

19-
runExport :: (FilePath -> Session a) -> IO a
20-
runExport act =
20+
-- | Open the named module in its own temporary single-file project, so each
21+
-- test compiles only the file it needs and cannot pick up signals from a
22+
-- sibling module.
23+
runExport :: FilePath -> (TextDocumentIdentifier -> Session a) -> IO a
24+
runExport hsFile act =
2125
runSessionWithTestConfig def
22-
{ testDirLocation = Left testDataDir
26+
{ testDirLocation = Right (mkVirtualFileTree testDataDir (directProject hsFile))
2327
, testPluginDescriptor = plugin
24-
} act
28+
} $ \_dir -> do
29+
doc <- openDoc hsFile "haskell"
30+
waitForKickDone
31+
act doc
2532

2633
codeActionTitles :: TextDocumentIdentifier -> Range -> Session [T.Text]
2734
codeActionTitles doc range =
@@ -62,214 +69,146 @@ rangeAt l c = Range (Position l c) (Position l c)
6269
main :: IO ()
6370
main = defaultTestRunner $ testGroup "Export"
6471
[ testGroup "Add: value bindings"
65-
[ testCase "add value to export list" $ runExport $ \_dir -> do
66-
doc <- openDoc "AddExport.hs" "haskell"
67-
waitForKickDone
72+
[ testCase "add value to export list" $ runExport "AddExport.hs" $ \doc -> do
6873
executeExportAction doc (rangeAt 6 0)
6974
containsAfter doc ["module AddExport (foo, Bar, bar)"]
7075

71-
, testCase "no action when value already exported" $ runExport $ \_dir -> do
72-
doc <- openDoc "AddExport.hs" "haskell"
73-
waitForKickDone
76+
, testCase "no action when value already exported" $ runExport "AddExport.hs" $ \doc ->
7477
noExportOffered doc (rangeAt 3 0) -- on `foo`
7578

76-
, testCase "append follows a multi-line leading-comma list" $ runExport $ \_dir -> do
77-
doc <- openDoc "AddExportMultiline.hs" "haskell"
78-
waitForKickDone
79+
, testCase "append follows a multi-line leading-comma list" $ runExport "AddExportMultiline.hs" $ \doc -> do
7980
executeExportAction doc (rangeAt 11 0) -- on `baz`
8081
containsAfter doc [" , baz\n ) where"]
8182
]
8283

8384
, testGroup "Add: type declarations"
84-
[ testCase "add bare type as T(..)" $ runExport $ \_dir -> do
85-
doc <- openDoc "AddExport.hs" "haskell"
86-
waitForKickDone
85+
[ testCase "add bare type as T(..)" $ runExport "AddExport.hs" $ \doc -> do
8786
executeExportAction doc (rangeAt 9 5) -- on `Baz` type name
8887
containsAfter doc ["Baz(..)", "Baz (..)"]
8988
]
9089

9190
, testGroup "Add: constructors"
92-
[ testCase "constructor with no parent entry appends T (C)" $ runExport $ \_dir -> do
93-
doc <- openDoc "AddExport.hs" "haskell"
94-
waitForKickDone
91+
[ testCase "constructor with no parent entry appends T (C)" $ runExport "AddExport.hs" $ \doc -> do
9592
executeExportAction doc (rangeAt 9 12) -- on `Baz1`, no Baz entry yet
9693
containsAfter doc ["Baz (Baz1)", "Baz(Baz1)"]
9794

98-
, testCase "constructor under bare-type parent promotes to T(C)" $ runExport $ \_dir -> do
99-
doc <- openDoc "AddCtor.hs" "haskell"
100-
waitForKickDone
95+
, testCase "constructor under bare-type parent promotes to T(C)" $ runExport "AddCtor.hs" $ \doc -> do
10196
executeExportAction doc (rangeAt 3 11) -- on `Bar1`, Bar is IEThingAbs
10297
containsAfter doc ["Bar (Bar1)", "Bar(Bar1)"]
10398

104-
, testCase "constructor merges into existing IEThingWith parent" $ runExport $ \_dir -> do
105-
doc <- openDoc "AddCtor.hs" "haskell"
106-
waitForKickDone
99+
, testCase "constructor merges into existing IEThingWith parent" $ runExport "AddCtor.hs" $ \doc -> do
107100
executeExportAction doc (rangeAt 2 18) -- on `Foo2`, Foo has [Foo1]
108101
containsAfter doc ["Foo (Foo1, Foo2)", "Foo(Foo1, Foo2)"]
109102

110-
, testCase "constructor already in IEThingWith children suppresses action" $ runExport $ \_dir -> do
111-
doc <- openDoc "AddCtor.hs" "haskell"
112-
waitForKickDone
103+
, testCase "constructor already in IEThingWith children suppresses action" $ runExport "AddCtor.hs" $ \doc ->
113104
noExportOffered doc (rangeAt 2 11) -- on `Foo1`, already child of Foo(Foo1)
114105

115-
, testCase "constructor under IEThingAll T(..) suppresses action" $ runExport $ \_dir -> do
116-
doc <- openDoc "AddCtor.hs" "haskell"
117-
waitForKickDone
106+
, testCase "constructor under IEThingAll T(..) suppresses action" $ runExport "AddCtor.hs" $ \doc ->
118107
noExportOffered doc (rangeAt 4 11) -- on `Baz1`, Baz(..) covers it
119108

120-
, testCase "constructor exported standalone suppresses action" $ runExport $ \_dir -> do
121-
doc <- openDoc "AddCtor.hs" "haskell"
122-
waitForKickDone
109+
, testCase "constructor exported standalone suppresses action" $ runExport "AddCtor.hs" $ \doc ->
123110
noExportOffered doc (rangeAt 5 11) -- on `Qux1`, Qux1 standalone in list
124111
]
125112

126113
, testGroup "Add: type classes"
127-
[ testCase "add class as T(..)" $ runExport $ \_dir -> do
128-
doc <- openDoc "AddClass.hs" "haskell"
129-
waitForKickDone
114+
[ testCase "add class as T(..)" $ runExport "AddClass.hs" $ \doc -> do
130115
executeExportAction doc (rangeAt 8 6) -- on `Baz` class name
131116
containsAfter doc ["module AddClass (Foo (..), Bar, Baz (..))"]
132117

133-
, testCase "no add action when class exported as T(..)" $ runExport $ \_dir -> do
134-
doc <- openDoc "AddClass.hs" "haskell"
135-
waitForKickDone
118+
, testCase "no add action when class exported as T(..)" $ runExport "AddClass.hs" $ \doc ->
136119
noExportOffered doc (rangeAt 2 6) -- on `Foo`, exported as Foo (..)
137120

138-
, testCase "no add action when class exported as bare T" $ runExport $ \_dir -> do
139-
doc <- openDoc "AddClass.hs" "haskell"
140-
waitForKickDone
121+
, testCase "no add action when class exported as bare T" $ runExport "AddClass.hs" $ \doc ->
141122
noExportOffered doc (rangeAt 5 6) -- on `Bar`, exported as bare
142123

143-
, testCase "no add action on class method" $ runExport $ \_dir -> do
144-
doc <- openDoc "AddClass.hs" "haskell"
145-
waitForKickDone
124+
, testCase "no add action on class method" $ runExport "AddClass.hs" $ \doc ->
146125
noExportOffered doc (rangeAt 9 2) -- on `baz1` inside `class Baz a where`
147126
]
148127

149128
, testGroup "Add: layout variants"
150-
[ testCase "add to an empty export list" $ runExport $ \_dir -> do
151-
doc <- openDoc "AddExportEmpty.hs" "haskell"
152-
waitForKickDone
129+
[ testCase "add to an empty export list" $ runExport "AddExportEmpty.hs" $ \doc -> do
153130
executeExportAction doc (rangeAt 2 0) -- on `foo`
154131
containsAfter doc ["module AddExportEmpty (foo) where"]
155132

156-
, testCase "append after a trailing comma" $ runExport $ \_dir -> do
157-
doc <- openDoc "AddExportTrailingComma.hs" "haskell"
158-
waitForKickDone
133+
, testCase "append after a trailing comma" $ runExport "AddExportTrailingComma.hs" $ \doc -> do
159134
executeExportAction doc (rangeAt 7 0) -- on `bar`
160135
containsAfter doc ["( foo, bar"]
161136

162-
, testCase "preserve a haddock comment between items" $ runExport $ \_dir -> do
163-
doc <- openDoc "AddExportComment.hs" "haskell"
164-
waitForKickDone
137+
, testCase "preserve a haddock comment between items" $ runExport "AddExportComment.hs" $ \doc -> do
165138
executeExportAction doc (rangeAt 16 0) -- on `quux`
166139
containsAfter doc [" -- * For testing\n , baz\n , quux\n ) where"]
167140
]
168141

169142
, testGroup "Add: declaration kinds"
170-
[ testCase "function operator is parenthesized" $ runExport $ \_dir -> do
171-
doc <- openDoc "AddExportKinds.hs" "haskell"
172-
waitForKickDone
143+
[ testCase "function operator is parenthesized" $ runExport "AddExportKinds.hs" $ \doc -> do
173144
executeExportAction doc (rangeAt 8 1) -- on `(<|)`
174145
containsAfter doc ["(placeholder, (<|))"]
175146

176-
, testCase "infix function exports bare name" $ runExport $ \_dir -> do
177-
doc <- openDoc "AddExportKinds.hs" "haskell"
178-
waitForKickDone
147+
, testCase "infix function exports bare name" $ runExport "AddExportKinds.hs" $ \doc -> do
179148
executeExportAction doc (rangeAt 11 3) -- on `f`
180149
containsAfter doc ["(placeholder, f)"]
181150

182-
, testCase "newtype exports as T(..)" $ runExport $ \_dir -> do
183-
doc <- openDoc "AddExportKinds.hs" "haskell"
184-
waitForKickDone
151+
, testCase "newtype exports as T(..)" $ runExport "AddExportKinds.hs" $ \doc -> do
185152
executeExportAction doc (rangeAt 13 8) -- on `NT`
186153
containsAfter doc ["placeholder, NT(..)", "placeholder, NT (..)"]
187154

188-
, testCase "type synonym exports bare" $ runExport $ \_dir -> do
189-
doc <- openDoc "AddExportKinds.hs" "haskell"
190-
waitForKickDone
155+
, testCase "type synonym exports bare" $ runExport "AddExportKinds.hs" $ \doc -> do
191156
executeExportAction doc (rangeAt 15 5) -- on `Syn`
192157
containsAfter doc ["(placeholder, Syn)"]
193158

194-
, testCase "type family exports bare" $ runExport $ \_dir -> do
195-
doc <- openDoc "AddExportKinds.hs" "haskell"
196-
waitForKickDone
159+
, testCase "type family exports bare" $ runExport "AddExportKinds.hs" $ \doc -> do
197160
executeExportAction doc (rangeAt 17 12) -- on `TF`
198161
containsAfter doc ["(placeholder, TF)"]
199162

200-
, testCase "pattern synonym gets a pattern prefix" $ runExport $ \_dir -> do
201-
doc <- openDoc "AddExportKinds.hs" "haskell"
202-
waitForKickDone
163+
, testCase "pattern synonym gets a pattern prefix" $ runExport "AddExportKinds.hs" $ \doc -> do
203164
executeExportAction doc (rangeAt 20 9) -- on `Pat`
204165
containsAfter doc ["(placeholder, pattern Pat)"]
205166

206-
, testCase "data operator gets type keyword and (..)" $ runExport $ \_dir -> do
207-
doc <- openDoc "AddExportKinds.hs" "haskell"
208-
waitForKickDone
167+
, testCase "data operator gets type keyword and (..)" $ runExport "AddExportKinds.hs" $ \doc -> do
209168
executeExportAction doc (rangeAt 22 7) -- on `(:<)`
210169
containsAfter doc ["placeholder, type (:<)(..)", "placeholder, type (:<) (..)"]
211170
]
212171

213172
, testGroup "Add: type-level operators"
214-
[ testCase "type synonym operator has no type keyword" $ runExport $ \_dir -> do
215-
doc <- openDoc "AddExportTypeOps.hs" "haskell"
216-
waitForKickDone
173+
[ testCase "type synonym operator has no type keyword" $ runExport "AddExportTypeOps.hs" $ \doc -> do
217174
executeExportAction doc (rangeAt 8 7) -- on `(:<>)`
218175
containsAfter doc ["(placeholder, (:<>))"]
219176

220-
, testCase "type family operator gets type keyword" $ runExport $ \_dir -> do
221-
doc <- openDoc "AddExportTypeOps.hs" "haskell"
222-
waitForKickDone
177+
, testCase "type family operator gets type keyword" $ runExport "AddExportTypeOps.hs" $ \doc -> do
223178
executeExportAction doc (rangeAt 10 14) -- on `(:+:)`
224179
containsAfter doc ["(placeholder, type (:+:))"]
225180

226-
, testCase "typeclass operator gets type keyword and (..)" $ runExport $ \_dir -> do
227-
doc <- openDoc "AddExportTypeOps.hs" "haskell"
228-
waitForKickDone
181+
, testCase "typeclass operator gets type keyword and (..)" $ runExport "AddExportTypeOps.hs" $ \doc -> do
229182
executeExportAction doc (rangeAt 12 8) -- on `(:*:)`
230183
containsAfter doc ["placeholder, type (:*:)(..)", "placeholder, type (:*:) (..)"]
231184

232-
, testCase "newtype operator gets type keyword and (..)" $ runExport $ \_dir -> do
233-
doc <- openDoc "AddExportTypeOps.hs" "haskell"
234-
waitForKickDone
185+
, testCase "newtype operator gets type keyword and (..)" $ runExport "AddExportTypeOps.hs" $ \doc -> do
235186
executeExportAction doc (rangeAt 14 10) -- on `(:->)`
236187
containsAfter doc ["placeholder, type (:->)(..)", "placeholder, type (:->) (..)"]
237188

238-
, testCase "pattern synonym operator is parenthesized" $ runExport $ \_dir -> do
239-
doc <- openDoc "AddExportTypeOps.hs" "haskell"
240-
waitForKickDone
189+
, testCase "pattern synonym operator is parenthesized" $ runExport "AddExportTypeOps.hs" $ \doc -> do
241190
executeExportAction doc (rangeAt 16 11) -- on `(:++)`
242191
containsAfter doc ["(placeholder, pattern (:++))"]
243192
]
244193

245194
, testGroup "Add: negative cases"
246-
[ testCase "no action on implicit module" $ runExport $ \_dir -> do
247-
doc <- openDoc "Implicit.hs" "haskell"
248-
waitForKickDone
195+
[ testCase "no action on implicit module" $ runExport "Implicit.hs" $ \doc ->
249196
noExportOffered doc (rangeAt 3 0)
250197

251-
, testCase "no action when cursor on RHS" $ runExport $ \_dir -> do
252-
doc <- openDoc "AddExport.hs" "haskell"
253-
waitForKickDone
198+
, testCase "no action when cursor on RHS" $ runExport "AddExport.hs" $ \doc ->
254199
noExportOffered doc (rangeAt 6 6) -- col 6 is on the `2` of `bar = 2`
255200

256-
, testCase "no action on a where-bound name" $ runExport $ \_dir -> do
257-
doc <- openDoc "AddExportNegatives.hs" "haskell"
258-
waitForKickDone
201+
, testCase "no action on a where-bound name" $ runExport "AddExportNegatives.hs" $ \doc ->
259202
noExportOffered doc (rangeAt 7 8) -- on `whereBound`
260203

261-
, testCase "no action on a record field" $ runExport $ \_dir -> do
262-
doc <- openDoc "AddExportNegatives.hs" "haskell"
263-
waitForKickDone
204+
, testCase "no action on a record field" $ runExport "AddExportNegatives.hs" $ \doc ->
264205
noExportOffered doc (rangeAt 9 18) -- on `recField`
265206
]
266207

267208
, testGroup "Export fixes the unused-binding warning"
268209
[ knownBrokenForGhcVersions [GHC96]
269210
"TcRnUnusedName provenance is unstructured before GHC 9.8 (GHC #20115)" $
270-
testCase "Export action attaches the -Wunused-top-binds diagnostic" $ runExport $ \_dir -> do
271-
doc <- openDoc "ExportUnusedFix.hs" "haskell"
272-
waitForKickDone
211+
testCase "Export action attaches the -Wunused-top-binds diagnostic" $ runExport "ExportUnusedFix.hs" $ \doc -> do
273212
actions <- rights . map toEither <$> getCodeActions doc (rangeAt 6 0) -- on `unused`
274213
case filter ((== "Export `unused`") . (^. L.title)) actions of
275214
(ca:_) -> liftIO $ not (null (fromMaybe [] (ca ^. L.diagnostics)))

‎plugins/hls-export-plugin/test/testdata/hie.yaml‎

Lines changed: 0 additions & 15 deletions
This file was deleted.

0 commit comments

Comments
 (0)