From 50d4b0aa88baf88bce1cdf60b5ec59cbb601c829 Mon Sep 17 00:00:00 2001
From: Sean D Gillespie <sean@mistersg.net>
Date: Tue, 24 Sep 2024 09:41:11 -0400
Subject: [PATCH] refactor: Create a type-level expect failure

---
 ghcide/test/exe/ReferenceTests.hs             | 42 +++++++++++++++----
 hls-test-utils/src/Test/Hls.hs                | 14 ++++++-
 .../src/Ide/Plugin/ExplicitFixity.hs          |  1 +
 3 files changed, 47 insertions(+), 10 deletions(-)

diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs
index fe6b8c7d04..50c263c4fc 100644
--- a/ghcide/test/exe/ReferenceTests.hs
+++ b/ghcide/test/exe/ReferenceTests.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE GADTs             #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -30,10 +31,13 @@ import           Ide.PluginUtils                 (toAbsolute)
 import           Ide.Types
 import           System.FilePath                 (addTrailingPathSeparator,
                                                   (</>))
-import           Test.Hls                        (FromServerMessage' (..),
+import           Test.Hls                        (BrokenBehavior (..),
+                                                  ExpectBroken (..),
+                                                  FromServerMessage' (..),
                                                   SMethod (..),
                                                   TCustomMessage (..),
-                                                  TNotificationMessage (..))
+                                                  TNotificationMessage (..),
+                                                  unCurrent)
 import           Test.Hls.FileSystem             (copyDir)
 import           Test.Tasty
 import           Test.Tasty.HUnit
@@ -90,15 +94,24 @@ tests = testGroup "references"
                           ]
 
           -- TODO: references provider does not respect includeDeclaration parameter
-          , referenceTest "INCORRECTLY returns declarations when we ask to exclude them"
+          , referenceTestExpectFail "works when we ask to exclude declarations"
                           ("References.hs", 4, 7)
                           NoExcludeDeclaration
-                          [ ("References.hs", 4, 6)
-                          , ("References.hs", 6, 0)
-                          , ("References.hs", 6, 14)
-                          , ("References.hs", 9, 7)
-                          , ("References.hs", 10, 11)
-                          ]
+                          (BrokenIdeal
+                            [ ("References.hs", 6, 0)
+                            , ("References.hs", 6, 14)
+                            , ("References.hs", 9, 7)
+                            , ("References.hs", 10, 11)
+                            ]
+                          )
+                          (BrokenCurrent
+                            [ ("References.hs", 4, 6)
+                            , ("References.hs", 6, 0)
+                            , ("References.hs", 6, 14)
+                            , ("References.hs", 9, 7)
+                            , ("References.hs", 10, 11)
+                            ]
+                          )
           ]
 
     , testGroup "can get references to non FOIs"
@@ -194,6 +207,17 @@ referenceTest name loc includeDeclaration expected =
   where
     docs = map fst3 expected
 
+referenceTestExpectFail
+  :: (HasCallStack)
+  => String
+  -> SymbolLocation
+  -> IncludeDeclaration
+  -> ExpectBroken 'Ideal [SymbolLocation]
+  -> ExpectBroken 'Current [SymbolLocation]
+  -> TestTree
+referenceTestExpectFail name loc includeDeclaration _ =
+  referenceTest name loc includeDeclaration . unCurrent
+
 type SymbolLocation = (FilePath, UInt, UInt)
 
 expectSameLocations :: (HasCallStack) => FilePath -> [Location] -> [SymbolLocation] -> Assertion
diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs
index 2ca477d896..1193b2dd19 100644
--- a/hls-test-utils/src/Test/Hls.hs
+++ b/hls-test-utils/src/Test/Hls.hs
@@ -39,6 +39,10 @@ module Test.Hls
     -- * Helpful re-exports
     PluginDescriptor,
     IdeState,
+    -- * Helpers for expected test case failuers
+    BrokenBehavior(..),
+    ExpectBroken(..),
+    unCurrent,
     -- * Assertion helper functions
     waitForProgressDone,
     waitForAllProgressDone,
@@ -166,6 +170,15 @@ instance Pretty LogTestHarness where
     LogCleanup     -> "Cleaned up temporary directory"
     LogNoCleanup   -> "No cleanup of temporary directory"
 
+data BrokenBehavior = Current | Ideal
+
+data ExpectBroken (k :: BrokenBehavior) a where
+  BrokenCurrent :: a -> ExpectBroken 'Current a
+  BrokenIdeal :: a -> ExpectBroken 'Ideal a
+
+unCurrent :: ExpectBroken 'Current a -> a
+unCurrent (BrokenCurrent a) = a
+
 -- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes
 defaultTestRunner :: TestTree -> IO ()
 defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000)
@@ -903,4 +916,3 @@ kick proxyMsg = do
   case fromJSON _params of
     Success x -> return x
     other     -> error $ "Failed to parse kick/done details: " <> show other
-
diff --git a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs
index 947570690b..7ed9a67e97 100644
--- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs
+++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies      #-}