Skip to content

Commit 9a7c87a

Browse files
crtschincrtschin
committed
Test the Export code action
1 parent f335d62 commit 9a7c87a

14 files changed

Lines changed: 425 additions & 0 deletions

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

Lines changed: 278 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,278 @@
1+
module Main (main) where
2+
3+
import Control.Lens ((^.))
4+
import Data.Either (rights)
5+
import Data.List (sort)
6+
import Data.Maybe (fromMaybe)
7+
import qualified Data.Text as T
8+
import Ide.Plugin.Export (descriptor)
9+
import qualified Language.LSP.Protocol.Lens as L
10+
import System.FilePath ((</>))
11+
import Test.Hls
12+
13+
plugin :: PluginTestDescriptor ()
14+
plugin = mkPluginTestDescriptor' descriptor "export"
15+
16+
testDataDir :: FilePath
17+
testDataDir = "plugins" </> "hls-export-plugin" </> "test" </> "testdata"
18+
19+
runExport :: (FilePath -> Session a) -> IO a
20+
runExport act =
21+
runSessionWithTestConfig def
22+
{ testDirLocation = Left testDataDir
23+
, testPluginDescriptor = plugin
24+
} act
25+
26+
codeActionTitles :: TextDocumentIdentifier -> Range -> Session [T.Text]
27+
codeActionTitles doc range =
28+
sort . map (^. L.title) . rights . map toEither
29+
<$> getCodeActions doc range
30+
31+
executeByPrefix :: T.Text -> TextDocumentIdentifier -> Range -> Session ()
32+
executeByPrefix prefix doc range = do
33+
actions <- rights . map toEither <$> getCodeActions doc range
34+
case filter (\ca -> prefix `T.isPrefixOf` (ca ^. L.title)) actions of
35+
(ca:_) -> executeCodeAction ca
36+
[] -> liftIO $ assertFailure (T.unpack prefix <> "...` action not offered")
37+
38+
executeExportAction :: TextDocumentIdentifier -> Range -> Session ()
39+
executeExportAction = executeByPrefix "Export `"
40+
41+
noActionWithPrefix :: T.Text -> TextDocumentIdentifier -> Range -> Session ()
42+
noActionWithPrefix prefix doc range = do
43+
titles <- codeActionTitles doc range
44+
liftIO $ not (any (prefix `T.isPrefixOf`) titles)
45+
@? ("Did not expect " <> T.unpack prefix <> " action; saw: " <> show titles)
46+
47+
noExportOffered :: TextDocumentIdentifier -> Range -> Session ()
48+
noExportOffered = noActionWithPrefix "Export `"
49+
50+
-- | Fail unless some variant is an infix of the text. The message dumps it.
51+
assertAnyInfix :: T.Text -> [T.Text] -> Assertion
52+
assertAnyInfix hay variants =
53+
any (`T.isInfixOf` hay) variants
54+
@? ("Expected one of " <> show variants <> " in:\n" <> T.unpack hay)
55+
56+
containsAfter :: TextDocumentIdentifier -> [T.Text] -> Session ()
57+
containsAfter doc expected = documentContents doc >>= liftIO . (`assertAnyInfix` expected)
58+
59+
rangeAt :: UInt -> UInt -> Range
60+
rangeAt l c = Range (Position l c) (Position l c)
61+
62+
main :: IO ()
63+
main = defaultTestRunner $ testGroup "Export"
64+
[ testGroup "Add: value bindings"
65+
[ testCase "add value to export list" $ runExport $ \_dir -> do
66+
doc <- openDoc "AddExport.hs" "haskell"
67+
waitForKickDone
68+
executeExportAction doc (rangeAt 6 0)
69+
containsAfter doc ["module AddExport (foo, Bar, bar)"]
70+
71+
, testCase "no action when value already exported" $ runExport $ \_dir -> do
72+
doc <- openDoc "AddExport.hs" "haskell"
73+
waitForKickDone
74+
noExportOffered doc (rangeAt 3 0) -- on `foo`
75+
76+
, testCase "append follows a multi-line leading-comma list" $ runExport $ \_dir -> do
77+
doc <- openDoc "AddExportMultiline.hs" "haskell"
78+
waitForKickDone
79+
executeExportAction doc (rangeAt 11 0) -- on `baz`
80+
containsAfter doc [" , baz\n ) where"]
81+
]
82+
83+
, testGroup "Add: type declarations"
84+
[ testCase "add bare type as T(..)" $ runExport $ \_dir -> do
85+
doc <- openDoc "AddExport.hs" "haskell"
86+
waitForKickDone
87+
executeExportAction doc (rangeAt 9 5) -- on `Baz` type name
88+
containsAfter doc ["Baz(..)", "Baz (..)"]
89+
]
90+
91+
, testGroup "Add: constructors"
92+
[ testCase "constructor with no parent entry appends T (C)" $ runExport $ \_dir -> do
93+
doc <- openDoc "AddExport.hs" "haskell"
94+
waitForKickDone
95+
executeExportAction doc (rangeAt 9 12) -- on `Baz1`, no Baz entry yet
96+
containsAfter doc ["Baz (Baz1)", "Baz(Baz1)"]
97+
98+
, testCase "constructor under bare-type parent promotes to T(C)" $ runExport $ \_dir -> do
99+
doc <- openDoc "AddCtor.hs" "haskell"
100+
waitForKickDone
101+
executeExportAction doc (rangeAt 3 11) -- on `Bar1`, Bar is IEThingAbs
102+
containsAfter doc ["Bar (Bar1)", "Bar(Bar1)"]
103+
104+
, testCase "constructor merges into existing IEThingWith parent" $ runExport $ \_dir -> do
105+
doc <- openDoc "AddCtor.hs" "haskell"
106+
waitForKickDone
107+
executeExportAction doc (rangeAt 2 18) -- on `Foo2`, Foo has [Foo1]
108+
containsAfter doc ["Foo (Foo1, Foo2)", "Foo(Foo1, Foo2)"]
109+
110+
, testCase "constructor already in IEThingWith children suppresses action" $ runExport $ \_dir -> do
111+
doc <- openDoc "AddCtor.hs" "haskell"
112+
waitForKickDone
113+
noExportOffered doc (rangeAt 2 11) -- on `Foo1`, already child of Foo(Foo1)
114+
115+
, testCase "constructor under IEThingAll T(..) suppresses action" $ runExport $ \_dir -> do
116+
doc <- openDoc "AddCtor.hs" "haskell"
117+
waitForKickDone
118+
noExportOffered doc (rangeAt 4 11) -- on `Baz1`, Baz(..) covers it
119+
120+
, testCase "constructor exported standalone suppresses action" $ runExport $ \_dir -> do
121+
doc <- openDoc "AddCtor.hs" "haskell"
122+
waitForKickDone
123+
noExportOffered doc (rangeAt 5 11) -- on `Qux1`, Qux1 standalone in list
124+
]
125+
126+
, testGroup "Add: type classes"
127+
[ testCase "add class as T(..)" $ runExport $ \_dir -> do
128+
doc <- openDoc "AddClass.hs" "haskell"
129+
waitForKickDone
130+
executeExportAction doc (rangeAt 8 6) -- on `Baz` class name
131+
containsAfter doc ["module AddClass (Foo (..), Bar, Baz (..))"]
132+
133+
, testCase "no add action when class exported as T(..)" $ runExport $ \_dir -> do
134+
doc <- openDoc "AddClass.hs" "haskell"
135+
waitForKickDone
136+
noExportOffered doc (rangeAt 2 6) -- on `Foo`, exported as Foo (..)
137+
138+
, testCase "no add action when class exported as bare T" $ runExport $ \_dir -> do
139+
doc <- openDoc "AddClass.hs" "haskell"
140+
waitForKickDone
141+
noExportOffered doc (rangeAt 5 6) -- on `Bar`, exported as bare
142+
143+
, testCase "no add action on class method" $ runExport $ \_dir -> do
144+
doc <- openDoc "AddClass.hs" "haskell"
145+
waitForKickDone
146+
noExportOffered doc (rangeAt 9 2) -- on `baz1` inside `class Baz a where`
147+
]
148+
149+
, testGroup "Add: layout variants"
150+
[ testCase "add to an empty export list" $ runExport $ \_dir -> do
151+
doc <- openDoc "AddExportEmpty.hs" "haskell"
152+
waitForKickDone
153+
executeExportAction doc (rangeAt 2 0) -- on `foo`
154+
containsAfter doc ["module AddExportEmpty (foo) where"]
155+
156+
, testCase "append after a trailing comma" $ runExport $ \_dir -> do
157+
doc <- openDoc "AddExportTrailingComma.hs" "haskell"
158+
waitForKickDone
159+
executeExportAction doc (rangeAt 7 0) -- on `bar`
160+
containsAfter doc ["( foo, bar"]
161+
162+
, testCase "preserve a haddock comment between items" $ runExport $ \_dir -> do
163+
doc <- openDoc "AddExportComment.hs" "haskell"
164+
waitForKickDone
165+
executeExportAction doc (rangeAt 16 0) -- on `quux`
166+
containsAfter doc [" -- * For testing\n , baz\n , quux\n ) where"]
167+
]
168+
169+
, testGroup "Add: declaration kinds"
170+
[ testCase "function operator is parenthesized" $ runExport $ \_dir -> do
171+
doc <- openDoc "AddExportKinds.hs" "haskell"
172+
waitForKickDone
173+
executeExportAction doc (rangeAt 8 1) -- on `(<|)`
174+
containsAfter doc ["(placeholder, (<|))"]
175+
176+
, testCase "infix function exports bare name" $ runExport $ \_dir -> do
177+
doc <- openDoc "AddExportKinds.hs" "haskell"
178+
waitForKickDone
179+
executeExportAction doc (rangeAt 11 3) -- on `f`
180+
containsAfter doc ["(placeholder, f)"]
181+
182+
, testCase "newtype exports as T(..)" $ runExport $ \_dir -> do
183+
doc <- openDoc "AddExportKinds.hs" "haskell"
184+
waitForKickDone
185+
executeExportAction doc (rangeAt 13 8) -- on `NT`
186+
containsAfter doc ["placeholder, NT(..)", "placeholder, NT (..)"]
187+
188+
, testCase "type synonym exports bare" $ runExport $ \_dir -> do
189+
doc <- openDoc "AddExportKinds.hs" "haskell"
190+
waitForKickDone
191+
executeExportAction doc (rangeAt 15 5) -- on `Syn`
192+
containsAfter doc ["(placeholder, Syn)"]
193+
194+
, testCase "type family exports bare" $ runExport $ \_dir -> do
195+
doc <- openDoc "AddExportKinds.hs" "haskell"
196+
waitForKickDone
197+
executeExportAction doc (rangeAt 17 12) -- on `TF`
198+
containsAfter doc ["(placeholder, TF)"]
199+
200+
, testCase "pattern synonym gets a pattern prefix" $ runExport $ \_dir -> do
201+
doc <- openDoc "AddExportKinds.hs" "haskell"
202+
waitForKickDone
203+
executeExportAction doc (rangeAt 20 9) -- on `Pat`
204+
containsAfter doc ["(placeholder, pattern Pat)"]
205+
206+
, testCase "data operator gets type keyword and (..)" $ runExport $ \_dir -> do
207+
doc <- openDoc "AddExportKinds.hs" "haskell"
208+
waitForKickDone
209+
executeExportAction doc (rangeAt 22 7) -- on `(:<)`
210+
containsAfter doc ["placeholder, type (:<)(..)", "placeholder, type (:<) (..)"]
211+
]
212+
213+
, 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
217+
executeExportAction doc (rangeAt 8 7) -- on `(:<>)`
218+
containsAfter doc ["(placeholder, (:<>))"]
219+
220+
, testCase "type family operator gets type keyword" $ runExport $ \_dir -> do
221+
doc <- openDoc "AddExportTypeOps.hs" "haskell"
222+
waitForKickDone
223+
executeExportAction doc (rangeAt 10 14) -- on `(:+:)`
224+
containsAfter doc ["(placeholder, type (:+:))"]
225+
226+
, testCase "typeclass operator gets type keyword and (..)" $ runExport $ \_dir -> do
227+
doc <- openDoc "AddExportTypeOps.hs" "haskell"
228+
waitForKickDone
229+
executeExportAction doc (rangeAt 12 8) -- on `(:*:)`
230+
containsAfter doc ["placeholder, type (:*:)(..)", "placeholder, type (:*:) (..)"]
231+
232+
, testCase "newtype operator gets type keyword and (..)" $ runExport $ \_dir -> do
233+
doc <- openDoc "AddExportTypeOps.hs" "haskell"
234+
waitForKickDone
235+
executeExportAction doc (rangeAt 14 10) -- on `(:->)`
236+
containsAfter doc ["placeholder, type (:->)(..)", "placeholder, type (:->) (..)"]
237+
238+
, testCase "pattern synonym operator is parenthesized" $ runExport $ \_dir -> do
239+
doc <- openDoc "AddExportTypeOps.hs" "haskell"
240+
waitForKickDone
241+
executeExportAction doc (rangeAt 16 11) -- on `(:++)`
242+
containsAfter doc ["(placeholder, pattern (:++))"]
243+
]
244+
245+
, testGroup "Add: negative cases"
246+
[ testCase "no action on implicit module" $ runExport $ \_dir -> do
247+
doc <- openDoc "Implicit.hs" "haskell"
248+
waitForKickDone
249+
noExportOffered doc (rangeAt 3 0)
250+
251+
, testCase "no action when cursor on RHS" $ runExport $ \_dir -> do
252+
doc <- openDoc "AddExport.hs" "haskell"
253+
waitForKickDone
254+
noExportOffered doc (rangeAt 6 6) -- col 6 is on the `2` of `bar = 2`
255+
256+
, testCase "no action on a where-bound name" $ runExport $ \_dir -> do
257+
doc <- openDoc "AddExportNegatives.hs" "haskell"
258+
waitForKickDone
259+
noExportOffered doc (rangeAt 7 8) -- on `whereBound`
260+
261+
, testCase "no action on a record field" $ runExport $ \_dir -> do
262+
doc <- openDoc "AddExportNegatives.hs" "haskell"
263+
waitForKickDone
264+
noExportOffered doc (rangeAt 9 18) -- on `recField`
265+
]
266+
267+
, testGroup "Export fixes the unused-binding warning"
268+
[ testCase "Export action attaches the -Wunused-top-binds diagnostic" $ runExport $ \_dir -> do
269+
doc <- openDoc "ExportUnusedFix.hs" "haskell"
270+
waitForKickDone
271+
actions <- rights . map toEither <$> getCodeActions doc (rangeAt 6 0) -- on `unused`
272+
case filter ((== "Export `unused`") . (^. L.title)) actions of
273+
(ca:_) -> liftIO $ not (null (fromMaybe [] (ca ^. L.diagnostics)))
274+
@? "Export action should carry the unused-binding diagnostic"
275+
[] -> liftIO $ assertFailure $
276+
"Export `unused` not offered; saw: " <> show (map (^. L.title) actions)
277+
]
278+
]

‎plugins/hls-export-plugin/test/testdata/AddClass.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
module AddClass (Foo (..), Bar) where
2+
3+
class Foo a where
4+
foo1 :: a -> Int
5+
6+
class Bar a where
7+
bar1 :: a -> Int
8+
9+
class Baz a where
10+
baz1 :: a -> Int

‎plugins/hls-export-plugin/test/testdata/AddCtor.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
module AddCtor (Foo (Foo1), Bar, Baz (..), Qux1) where
2+
3+
data Foo = Foo1 | Foo2 | Foo3
4+
data Bar = Bar1 | Bar2
5+
data Baz = Baz1 | Baz2
6+
data Qux = Qux1 | Qux2

‎plugins/hls-export-plugin/test/testdata/AddExport.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
module AddExport (foo, Bar) where
2+
3+
foo :: Int
4+
foo = 1
5+
6+
bar :: Int
7+
bar = 2
8+
9+
data Bar = Bar
10+
data Baz = Baz1 | Baz2

‎plugins/hls-export-plugin/test/testdata/AddExportComment.hs‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
module AddExportComment
2+
( foo
3+
, bar
4+
-- * For testing
5+
, baz
6+
) where
7+
8+
foo :: Int
9+
foo = 1
10+
11+
bar :: Int
12+
bar = 2
13+
14+
baz :: Int
15+
baz = 3
16+
17+
quux :: Int
18+
quux = 4

‎plugins/hls-export-plugin/test/testdata/AddExportEmpty.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
module AddExportEmpty () where
2+
3+
foo :: Int
4+
foo = 1

‎plugins/hls-export-plugin/test/testdata/AddExportKinds.hs‎

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
{-# LANGUAGE PatternSynonyms #-}
2+
{-# LANGUAGE TypeFamilies #-}
3+
{-# LANGUAGE TypeOperators #-}
4+
module AddExportKinds (placeholder) where
5+
6+
placeholder :: Int
7+
placeholder = 0
8+
9+
(<|) :: a -> a -> a
10+
(<|) x _ = x
11+
12+
a `f` b = b
13+
14+
newtype NT = NT ()
15+
16+
type Syn = ()
17+
18+
type family TF p
19+
20+
pattern Pat :: a -> (a, a)
21+
pattern Pat a = (a, a)
22+
23+
data (:<) = Mk

‎plugins/hls-export-plugin/test/testdata/AddExportMultiline.hs‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
module AddExportMultiline
2+
( foo
3+
, bar
4+
) where
5+
6+
foo :: Int
7+
foo = 1
8+
9+
bar :: Int
10+
bar = 2
11+
12+
baz :: Int
13+
baz = 3

‎plugins/hls-export-plugin/test/testdata/AddExportNegatives.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
module AddExportNegatives (placeholder) where
2+
3+
placeholder :: Int
4+
placeholder = 0
5+
6+
withWhere :: ()
7+
withWhere = whereBound
8+
where whereBound = ()
9+
10+
data Rec = Rec { recField :: () }

‎plugins/hls-export-plugin/test/testdata/AddExportTrailingComma.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
module AddExportTrailingComma
2+
( foo,
3+
) where
4+
5+
foo :: Int
6+
foo = 1
7+
8+
bar :: Int
9+
bar = 2

0 commit comments

Comments
 (0)