From 140cdcd3ed6c482509db61fe2d46f29861ea7d02 Mon Sep 17 00:00:00 2001
From: Sandy Maguire <sandy@sandymaguire.me>
Date: Thu, 24 Jun 2021 22:39:03 -0700
Subject: [PATCH] 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>
---
 .../hls-tactics-plugin/src/Wingman/EmptyCase.hs  | 15 +++++++++------
 .../test/CodeLens/EmptyCaseSpec.hs               |  4 ++++
 plugins/hls-tactics-plugin/test/Utils.hs         | 16 ++++++++++++++--
 .../test/golden/EmptyCaseSpuriousGADT.hs         |  8 ++++++++
 4 files changed, 35 insertions(+), 8 deletions(-)
 create mode 100644 plugins/hls-tactics-plugin/test/golden/EmptyCaseSpuriousGADT.hs

diff --git a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs
index 70877096073..8335642a4eb 100644
--- 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
index ce7a6b60df4..9ebf7d5043a 100644
--- 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
index c1832503a63..26cfc343d1f 100644
--- 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
new file mode 100644
index 00000000000..25906fe536e
--- /dev/null
+++ 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
+