Skip to content

Commit ffebc7b

Browse files
jneirajneira
authored
Merge pull request #674 from jneira/hlint-tests
Add hlint tests over cpp, extensions and ignore hints
2 parents f78f40c + 4fa0129 commit ffebc7b

File tree

17 files changed

+246
-41
lines changed

17 files changed

+246
-41
lines changed

‎haskell-language-server.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -200,6 +200,7 @@ common hls-test-utils
200200
, lens
201201
, lsp-test >=0.11.0.6
202202
, stm
203+
, tasty-expected-failure
203204
, tasty-hunit
204205
, temporary
205206
, transformers
@@ -227,7 +228,6 @@ test-suite func-test
227228
, lens
228229
, tasty
229230
, tasty-ant-xml >=1.1.6
230-
, tasty-expected-failure
231231
, tasty-golden
232232
, tasty-rerun
233233

‎test/functional/FunctionalCodeAction.hs‎

Lines changed: 84 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -20,8 +20,9 @@ import qualified Language.Haskell.LSP.Types.Lens as L
2020
import qualified Language.Haskell.LSP.Types.Capabilities as C
2121
import Test.Hls.Util
2222
import Test.Tasty
23-
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
23+
import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecause)
2424
import Test.Tasty.HUnit
25+
import System.FilePath ((</>))
2526

2627
{-# ANN module ("HLint: ignore Reduce duplication"::String) #-}
2728

@@ -41,7 +42,7 @@ tests = testGroup "code actions" [
4142

4243
hlintTests :: TestTree
4344
hlintTests = testGroup "hlint suggestions" [
44-
testCase "provides 3.8 code actions including apply all" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do
45+
testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do
4546
doc <- openDoc "ApplyRefact2.hs" "haskell"
4647
diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint"
4748

@@ -73,55 +74,110 @@ hlintTests = testGroup "hlint suggestions" [
7374
_ <- waitForDiagnosticsFromSource doc "hlint"
7475

7576
cars <- getAllCodeActions doc
76-
etaReduce <- liftIO $ inspectCommand cars ["Apply hint: Eta reduce"]
77+
etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"]
7778

7879
executeCommand etaReduce
7980

8081
contents <- skipManyTill anyMessage $ getDocumentEdit doc
8182
liftIO $ contents @?= "main = undefined\nfoo = id\n"
8283

83-
, testCase "changing configuration enables or disables hlint diagnostics" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do
84+
, testCase "changing configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do
8485
let config = def { hlintOn = True }
8586
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
8687

8788
doc <- openDoc "ApplyRefact2.hs" "haskell"
88-
diags <- waitForDiagnosticsFromSource doc "hlint"
89-
90-
liftIO $ length diags > 0 @? "There are hlint diagnostics"
89+
testHlintDiagnostics doc
9190

9291
let config' = def { hlintOn = False }
9392
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config'))
9493

9594
diags' <- waitForDiagnosticsFrom doc
9695

97-
liftIO $ Just "hlint" `notElem` map (^. L.source) diags' @? "There are no hlint diagnostics"
98-
99-
, testCase "changing document contents updates hlint diagnostics" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do
100-
doc <- openDoc "ApplyRefact2.hs" "haskell"
101-
diags <- waitForDiagnosticsSource "hlint"
102-
103-
liftIO $ length diags @?= 2 -- "Eta Reduce" and "Redundant Id"
104-
105-
let change = TextDocumentContentChangeEvent
106-
(Just (Range (Position 1 8) (Position 1 12)))
107-
Nothing "x"
96+
liftIO $ noHlintDiagnostics diags'
10897

109-
changeDoc doc [change]
98+
, knownBrokenForGhcVersions [GHC88, GHC86] "hlint doesn't take in account cpp flag as ghc -D argument" $
99+
testCase "hlint diagnostics works with CPP via ghc -XCPP argument (#554)" $ runHlintSession "cpp" $ do
100+
doc <- openDoc "ApplyRefact3.hs" "haskell"
101+
testHlintDiagnostics doc
110102

111-
diags' <- waitForDiagnostics
103+
, knownBrokenForGhcVersions [GHC88, GHC86] "hlint doesn't take in account cpp flag as ghc -D argument" $
104+
testCase "hlint diagnostics works with CPP via language pragma (#554)" $ runHlintSession "" $ do
105+
doc <- openDoc "ApplyRefact3.hs" "haskell"
106+
testHlintDiagnostics doc
112107

113-
liftIO $ (not $ Just "hlint" `elem` map (^. L.source) diags') @? "There are no hlint diagnostics"
108+
, testCase "hlint diagnostics works with CPP via -XCPP argument and flag via #include header (#554)" $ runHlintSession "cpp" $ do
109+
doc <- openDoc "ApplyRefact2.hs" "haskell"
110+
testHlintDiagnostics doc
111+
112+
, knownBrokenForGhcVersions [GHC88, GHC86] "apply-refact doesn't take in account the -X argument" $
113+
testCase "apply-refact works with LambdaCase via ghc -XLambdaCase argument (#590)" $ runHlintSession "lambdacase" $ do
114+
testRefactor "ApplyRefact1.hs" "Redundant bracket"
115+
expectedLambdaCase
116+
117+
, testCase "apply hints works with LambdaCase via language pragma" $ runHlintSession "" $ do
118+
testRefactor "ApplyRefact1.hs" "Redundant bracket"
119+
("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase)
120+
121+
, expectFailBecause "apply-refact doesn't work with cpp" $
122+
testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession "cpp" $ do
123+
testRefactor "ApplyRefact3.hs" "Redundant bracket"
124+
expectedCPP
125+
126+
, expectFailBecause "apply-refact doesn't work with cpp" $
127+
testCase "apply hints works with CPP via language pragma" $ runHlintSession "" $ do
128+
testRefactor "ApplyRefact3.hs" "Redundant bracket"
129+
("{-# LANGUAGE CPP #-}" : expectedCPP)
130+
131+
, testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession "ignore" $ do
132+
doc <- openDoc "ApplyRefact.hs" "haskell"
133+
expectNoMoreDiagnostics 3 doc "hlint"
134+
135+
, testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession "" $ do
136+
doc <- openDoc "ApplyRefact4.hs" "haskell"
137+
expectNoMoreDiagnostics 3 doc "hlint"
138+
139+
, knownBrokenForGhcVersions [GHC810] "hlint plugin doesn't honour HLINT annotations (#838)" $
140+
testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do
141+
doc <- openDoc "ApplyRefact5.hs" "haskell"
142+
expectNoMoreDiagnostics 3 doc "hlint"
143+
]
144+
where
145+
runHlintSession :: FilePath -> Session a -> IO a
146+
runHlintSession subdir =
147+
failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata/hlint" </> subdir)
114148

115-
let change' = TextDocumentContentChangeEvent
116-
(Just (Range (Position 1 8) (Position 1 12)))
117-
Nothing "id x"
149+
noHlintDiagnostics :: [Diagnostic] -> Assertion
150+
noHlintDiagnostics diags =
151+
Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics"
118152

119-
changeDoc doc [change']
153+
testHlintDiagnostics doc = do
154+
diags <- waitForDiagnosticsFromSource doc "hlint"
155+
liftIO $ length diags > 0 @? "There are hlint diagnostics"
120156

121-
diags'' <- waitForDiagnosticsFromSource doc "hlint"
157+
testRefactor file caTitle expected = do
158+
doc <- openDoc file "haskell"
159+
testHlintDiagnostics doc
122160

123-
liftIO $ length diags'' @?= 2
124-
]
161+
cas <- map fromAction <$> getAllCodeActions doc
162+
let ca = find (\ca -> caTitle `T.isSuffixOf` (ca ^. L.title)) cas
163+
liftIO $ isJust ca @? ("There is '" ++ T.unpack caTitle ++"' code action")
164+
165+
executeCodeAction (fromJust ca)
166+
167+
contents <- getDocumentEdit doc
168+
liftIO $ contents @?= T.unlines expected
169+
170+
expectedLambdaCase = [ "module ApplyRefact1 where", ""
171+
, "f = \\case \"true\" -> True"
172+
, " _ -> False"
173+
]
174+
expectedCPP = [ "module ApplyRefact3 where", ""
175+
, "#ifdef FLAG"
176+
, "f = 1"
177+
, "#else"
178+
, "g = 2"
179+
, "#endif", ""
180+
]
125181

126182
renameTests :: TestTree
127183
renameTests = testGroup "rename suggestions" [

‎test/testdata/hlint/ApplyRefact1.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
module ApplyRefact1 where
3+
4+
f = \case "true" -> (True)
5+
_ -> False

‎test/testdata/hlint/ApplyRefact3.hs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
{-# LANGUAGE CPP #-}
2+
module ApplyRefact3 where
3+
4+
#ifdef FLAG
5+
f = (1)
6+
#else
7+
g = 2
8+
#endif

‎test/testdata/hlint/ApplyRefact4.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module ApplyRefact4 where
2+
3+
{-# ANN module "HLint: ignore Redundant bracket" #-}
4+
f = (1)
5+

‎test/testdata/hlint/ApplyRefact5.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
module ApplyRefact5 where
2+
3+
{- HLINT ignore "Redundant bracket" -}
4+
f = (1)
5+
6+
{-# HLINT ignore "Use camelCase" #-}
7+
camel_case = undefined

‎test/testdata/hlint/cpp/ApplyRefact2.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
module ApplyRefact2 where
2+
3+
#include "test.h"
4+
5+
#ifdef TEST
6+
f = (1)
7+
#else
8+
f = 1
9+
#endif

‎test/testdata/hlint/cpp/ApplyRefact3.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
module ApplyRefact3 where
2+
3+
#ifdef FLAG
4+
f = (1)
5+
#else
6+
g = 2
7+
#endif

‎test/testdata/hlint/cpp/hie.yaml‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
cradle:
2+
direct:
3+
arguments:
4+
- "-XCPP"
5+
- "-DFLAG"
6+
- "ApplyRefact3"
7+
- "ApplyRefact2"

‎test/testdata/hlint/cpp/test.h‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
#define TEST

0 commit comments

Comments
 (0)