Add hlint tests over cpp, extensions and ignore hints

haskell-language-server.cabal

@@ -200,6 +200,7 @@ common hls-test-utils
     , lens
     , lsp-test              >=0.11.0.6
     , stm
+    , tasty-expected-failure
     , tasty-hunit
     , temporary
     , transformers
@@ -227,7 +228,6 @@ test-suite func-test
     , lens
     , tasty
     , tasty-ant-xml           >=1.1.6
-    , tasty-expected-failure
     , tasty-golden
     , tasty-rerun
 

test/functional/FunctionalCodeAction.hs

@@ -20,8 +20,9 @@ import qualified Language.Haskell.LSP.Types.Lens as L
 import qualified Language.Haskell.LSP.Types.Capabilities as C
 import           Test.Hls.Util
 import           Test.Tasty
-import           Test.Tasty.ExpectedFailure (ignoreTestBecause)
+import           Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecause)
 import           Test.Tasty.HUnit
+import           System.FilePath ((</>))
 
 {-# ANN module ("HLint: ignore Reduce duplication"::String) #-}
 
@@ -41,7 +42,7 @@ tests = testGroup "code actions" [
 
 hlintTests :: TestTree
 hlintTests = testGroup "hlint suggestions" [
-    testCase "provides 3.8 code actions including apply all" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do
+    testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do
         doc <- openDoc "ApplyRefact2.hs" "haskell"
         diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint"
 
@@ -73,55 +74,110 @@ hlintTests = testGroup "hlint suggestions" [
         _ <- waitForDiagnosticsFromSource doc "hlint"
 
         cars <- getAllCodeActions doc
-        etaReduce <- liftIO $ inspectCommand cars ["Apply hint: Eta reduce"]
+        etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"]
 
         executeCommand etaReduce
 
         contents <- skipManyTill anyMessage $ getDocumentEdit doc
         liftIO $ contents @?= "main = undefined\nfoo = id\n"
 
-    , testCase "changing configuration enables or disables hlint diagnostics" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do
+    , testCase "changing configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do
         let config = def { hlintOn = True }
         sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
 
         doc <- openDoc "ApplyRefact2.hs" "haskell"
-        diags <- waitForDiagnosticsFromSource doc "hlint"
-
-        liftIO $ length diags > 0 @? "There are hlint diagnostics"
+        testHlintDiagnostics doc
 
         let config' = def { hlintOn = False }
         sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config'))
 
         diags' <- waitForDiagnosticsFrom doc
 
-        liftIO $ Just "hlint" `notElem` map (^. L.source) diags' @? "There are no hlint diagnostics"
-
-    , testCase "changing document contents updates hlint diagnostics" $ runSession hlsCommand fullCaps "test/testdata/hlint" $ do
-        doc <- openDoc "ApplyRefact2.hs" "haskell"
-        diags <- waitForDiagnosticsSource "hlint"
-
-        liftIO $ length diags @?= 2 -- "Eta Reduce" and "Redundant Id"
-
-        let change = TextDocumentContentChangeEvent
-                        (Just (Range (Position 1 8) (Position 1 12)))
-                         Nothing "x"
+        liftIO $ noHlintDiagnostics diags'
 
-        changeDoc doc [change]
+    , knownBrokenForGhcVersions [GHC88, GHC86] "hlint doesn't take in account cpp flag as ghc -D argument" $
+      testCase "hlint diagnostics works with CPP via ghc -XCPP argument (#554)" $ runHlintSession "cpp" $ do
+        doc <- openDoc "ApplyRefact3.hs" "haskell"
+        testHlintDiagnostics doc
 
-        diags' <- waitForDiagnostics
+    , knownBrokenForGhcVersions [GHC88, GHC86] "hlint doesn't take in account cpp flag as ghc -D argument" $
+      testCase "hlint diagnostics works with CPP via language pragma (#554)" $ runHlintSession "" $ do
+        doc <- openDoc "ApplyRefact3.hs" "haskell"
+        testHlintDiagnostics doc
 
-        liftIO $ (not $ Just "hlint" `elem` map (^. L.source) diags') @? "There are no hlint diagnostics"
+    , testCase "hlint diagnostics works with CPP via -XCPP argument and flag via #include header (#554)" $ runHlintSession "cpp" $ do
+        doc <- openDoc "ApplyRefact2.hs" "haskell"
+        testHlintDiagnostics doc
+
+    , knownBrokenForGhcVersions [GHC88, GHC86] "apply-refact doesn't take in account the -X argument" $
+      testCase "apply-refact works with LambdaCase via ghc -XLambdaCase argument (#590)" $ runHlintSession "lambdacase" $ do
+        testRefactor "ApplyRefact1.hs" "Redundant bracket"
+            expectedLambdaCase
+
+    , testCase "apply hints works with LambdaCase via language pragma" $ runHlintSession "" $ do
+        testRefactor "ApplyRefact1.hs" "Redundant bracket"
+            ("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase)
+
+    , expectFailBecause "apply-refact doesn't work with cpp" $
+      testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession "cpp" $ do
+        testRefactor "ApplyRefact3.hs" "Redundant bracket"
+            expectedCPP
+
+    , expectFailBecause "apply-refact doesn't work with cpp" $
+      testCase "apply hints works with CPP via language pragma" $ runHlintSession "" $ do
+        testRefactor "ApplyRefact3.hs" "Redundant bracket"
+            ("{-# LANGUAGE CPP #-}" : expectedCPP)
+
+    , testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession "ignore" $ do
+        doc <- openDoc "ApplyRefact.hs" "haskell"
+        expectNoMoreDiagnostics 3 doc "hlint"
+
+    , testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession "" $ do
+        doc <- openDoc "ApplyRefact4.hs" "haskell"
+        expectNoMoreDiagnostics 3 doc "hlint"
+
+    , knownBrokenForGhcVersions [GHC810] "hlint plugin doesn't honour HLINT annotations (#838)" $
+      testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do
+        doc <- openDoc "ApplyRefact5.hs" "haskell"
+        expectNoMoreDiagnostics 3 doc "hlint"
+    ]
+    where
+        runHlintSession :: FilePath -> Session a -> IO a
+        runHlintSession subdir  =
+            failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata/hlint" </> subdir)
 
-        let change' = TextDocumentContentChangeEvent
-                        (Just (Range (Position 1 8) (Position 1 12)))
-                         Nothing "id x"
+        noHlintDiagnostics :: [Diagnostic] -> Assertion
+        noHlintDiagnostics diags =
+            Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics"
 
-        changeDoc doc [change']
+        testHlintDiagnostics doc = do
+            diags <- waitForDiagnosticsFromSource doc "hlint"
+            liftIO $ length diags > 0 @? "There are hlint diagnostics"
 
-        diags'' <- waitForDiagnosticsFromSource doc "hlint"
+        testRefactor file caTitle expected = do
+            doc <- openDoc file "haskell"
+            testHlintDiagnostics doc
 
-        liftIO $ length diags'' @?= 2
-    ]
+            cas <- map fromAction <$> getAllCodeActions doc
+            let ca = find (\ca -> caTitle `T.isSuffixOf` (ca ^. L.title)) cas
+            liftIO $ isJust ca @? ("There is '" ++ T.unpack caTitle ++"' code action")
+
+            executeCodeAction (fromJust ca)
+
+            contents <- getDocumentEdit doc
+            liftIO $ contents @?= T.unlines expected
+
+        expectedLambdaCase = [ "module ApplyRefact1 where", ""
+                             , "f = \\case \"true\" -> True"
+                             , "          _ -> False"
+                             ]
+        expectedCPP =        [ "module ApplyRefact3 where", ""
+                             , "#ifdef FLAG"
+                             , "f = 1"
+                             , "#else"
+                             , "g = 2"
+                             , "#endif", ""
+                             ]
 
 renameTests :: TestTree
 renameTests = testGroup "rename suggestions" [

test/testdata/hlint/ApplyRefact1.hs

@@ -0,0 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
+module ApplyRefact1 where
+
+f = \case "true" -> (True)
+          _ -> False

test/testdata/hlint/ApplyRefact3.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE CPP #-}
+module ApplyRefact3 where
+
+#ifdef FLAG
+f = (1)
+#else
+g = 2
+#endif

test/testdata/hlint/ApplyRefact4.hs

@@ -0,0 +1,5 @@
+module ApplyRefact4 where
+
+{-# ANN module "HLint: ignore Redundant bracket" #-}
+f = (1)
+

test/testdata/hlint/ApplyRefact5.hs

@@ -0,0 +1,7 @@
+module ApplyRefact5 where
+
+{- HLINT ignore "Redundant bracket" -}
+f = (1)
+
+{-# HLINT ignore "Use camelCase" #-}
+camel_case = undefined

test/testdata/hlint/cpp/ApplyRefact2.hs

@@ -0,0 +1,9 @@
+module ApplyRefact2 where
+
+#include "test.h"
+
+#ifdef TEST
+f = (1)
+#else
+f = 1
+#endif

test/testdata/hlint/cpp/ApplyRefact3.hs

@@ -0,0 +1,7 @@
+module ApplyRefact3 where
+
+#ifdef FLAG
+f = (1)
+#else
+g = 2
+#endif

test/testdata/hlint/cpp/hie.yaml

@@ -0,0 +1,7 @@
+cradle:
+  direct:
+    arguments:
+      - "-XCPP"
+      - "-DFLAG"
+      - "ApplyRefact3"
+      - "ApplyRefact2"

test/testdata/hlint/cpp/test.h

@@ -0,0 +1 @@
+#define TEST

test/testdata/hlint/hie.yaml

@@ -1,4 +1,10 @@
 cradle:
   direct:
     arguments:
+      - "-DFLAG"
+      - "-Wno-unrecognised-pragmas"
+      - "ApplyRefact1"
       - "ApplyRefact2"
+      - "ApplyRefact3"
+      - "ApplyRefact4"
+      - "ApplyRefact5"

test/testdata/hlint/ignore/.hlint.yaml

@@ -0,0 +1,2 @@
+- ignore: { name: "Redundant bracket" }
+- ignore: { name: "Use camelCase" }

test/testdata/hlint/ignore/ApplyRefact.hs

@@ -0,0 +1,5 @@
+module ApplyRefact where
+
+f = (1)
+
+camel_case = undefined

test/testdata/hlint/ignore/hie.yaml

@@ -0,0 +1,4 @@
+cradle:
+  direct:
+    arguments:
+      - "ApplyRefact"

test/testdata/hlint/lambdacase/ApplyRefact1.hs

@@ -0,0 +1,4 @@
+module ApplyRefact1 where
+
+f = \case "true" -> (True)
+          _ -> False

test/testdata/hlint/lambdacase/hie.yaml

@@ -0,0 +1,5 @@
+cradle:
+  direct:
+    arguments:
+      - "-XLambdaCase"
+      - "ApplyRefact1"