Don't suggest empty case lenses for case exprs with no data cons (#1962)

Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
haskell · Jun 25, 2021 · 140cdcd · 140cdcd
1 parent 80ecf98
commit 140cdcd
Show file tree

Hide file tree

Showing 4 changed files with 35 additions and 8 deletions.
diff --git a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs
@@ -150,16 +150,19 @@ emptyCaseScrutinees state nfp = do
     hscenv <- stale GhcSessionDeps
 
     let scrutinees = traverse (emptyCaseQ . tcg_binds) tcg
-    for scrutinees $ \aged@(unTrack -> (ss, scrutinee)) -> do
+    fmap catMaybes $ for scrutinees $ \aged@(unTrack -> (ss, scrutinee)) -> do
       ty <- MaybeT
           . fmap (scrutinzedType <=< sequence)
           . traverse (typeCheck (hscEnv $ untrackedStaleValue hscenv) tcg')
           $ scrutinee
-      case ss of
-        RealSrcSpan r   -> do
-          rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r
-          pure (rss', ty)
-        UnhelpfulSpan _ -> empty
+      case null $ tacticsGetDataCons ty of
+        True -> pure empty
+        False ->
+          case ss of
+            RealSrcSpan r   -> do
+              rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r
+              pure $ Just (rss', ty)
+            UnhelpfulSpan _ -> empty
 
 data EmptyCaseSort a
   = EmptyCase a

diff --git a/plugins/hls-tactics-plugin/test/CodeLens/EmptyCaseSpec.hs b/plugins/hls-tactics-plugin/test/CodeLens/EmptyCaseSpec.hs
@@ -9,6 +9,7 @@ import Utils
 spec :: Spec
 spec = do
   let test = mkCodeLensTest
+      noTest = mkNoCodeLensTest
 
   describe "golden" $ do
     test "EmptyCaseADT"
@@ -19,3 +20,6 @@ spec = do
     test "EmptyCaseGADT"
     test "EmptyCaseLamCase"
 
+  describe "no code lenses" $ do
+    noTest "EmptyCaseSpuriousGADT"
+
diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs
@@ -15,12 +15,10 @@ import           Control.Monad.IO.Class
 import           Data.Aeson
 import           Data.Foldable
 import           Data.Function (on)
-import qualified Data.Map as M
 import           Data.Maybe
 import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
-import qualified Ide.Plugin.Config as Plugin
 import           Ide.Plugin.Tactic as Tactic
 import           Language.LSP.Types
 import           Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title)
@@ -129,6 +127,20 @@ mkCodeLensTest input =
       liftIO $ edited `shouldBe` expected
 
 
+------------------------------------------------------------------------------
+-- | A test that no code lenses can be run in the file
+mkNoCodeLensTest
+    :: FilePath
+    -> SpecWith ()
+mkNoCodeLensTest input =
+  it (input <> " (no code lenses)") $ do
+    runSessionWithServer plugin tacticPath $ do
+      doc <- openDoc (input <.> "hs") "haskell"
+      _ <- waitForDiagnostics
+      lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc
+      liftIO $ lenses `shouldBe` []
+
+
 
 isWingmanLens :: CodeLens -> Bool
 isWingmanLens (CodeLens _ (Just (Command _ cmd _)) _)

diff --git a/plugins/hls-tactics-plugin/test/golden/EmptyCaseSpuriousGADT.hs b/plugins/hls-tactics-plugin/test/golden/EmptyCaseSpuriousGADT.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE GADTs #-}
+
+data Foo a where
+  Foo :: Foo Int
+
+foo :: Foo Bool -> ()
+foo x = case x of
+