Resolve some of soulomoon's feedback

Author: Jaro Reinders

hls-test-utils/src/Development/IDE/Test.hs

@@ -63,10 +63,13 @@ import           System.FilePath                 (equalFilePath)
 import           System.Time.Extra
 import           Test.Tasty.HUnit
 
+expectedDiagnosticWithNothing :: ExpectedDiagnostic -> ExpectedDiagnosticWithTag
+expectedDiagnosticWithNothing (ds, c, t, code) = (ds, c, t, code, Nothing)
+
 requireDiagnosticM
     :: (Foldable f, Show (f Diagnostic), HasCallStack)
     => f Diagnostic
-    -> (DiagnosticSeverity, Cursor, T.Text, Maybe T.Text, Maybe DiagnosticTag)
+    -> ExpectedDiagnosticWithTag
     -> Assertion
 requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of
     Nothing  -> pure ()
@@ -114,15 +117,15 @@ flushMessages = do
 --
 --   Rather than trying to assert the absence of diagnostics, introduce an
 --   expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic.
-expectDiagnostics :: HasCallStack => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text)])] -> Session ()
+expectDiagnostics :: HasCallStack => [(FilePath, [ExpectedDiagnostic])] -> Session ()
 expectDiagnostics
   = expectDiagnosticsWithTags
-  . map (second (map (\(ds, c, t, code) -> (ds, c, t, code, Nothing))))
+  . map (second (map expectedDiagnosticWithNothing))
 
 unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics  -> (Uri, [Diagnostic])
 unwrapDiagnostic diagsNot = (diagsNot^. L.params . L.uri, diagsNot^. L.params . L.diagnostics)
 
-expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text, Maybe DiagnosticTag)])] -> Session ()
+expectDiagnosticsWithTags :: HasCallStack => [(String, [ExpectedDiagnosticWithTag])] -> Session ()
 expectDiagnosticsWithTags expected = do
     let toSessionPath = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri
         next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic
@@ -132,7 +135,7 @@ expectDiagnosticsWithTags expected = do
 expectDiagnosticsWithTags' ::
   (HasCallStack, MonadIO m) =>
   m (Uri, [Diagnostic]) ->
-  Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text, Maybe DiagnosticTag)] ->
+  Map.Map NormalizedUri [ExpectedDiagnosticWithTag] ->
   m ()
 expectDiagnosticsWithTags' next m | null m = do
     (_,actual) <- next
@@ -170,14 +173,14 @@ expectDiagnosticsWithTags' next expected = go expected
                     <> show actual
             go $ Map.delete canonUri m
 
-expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text)] -> Session ()
+expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [ExpectedDiagnostic] -> Session ()
 expectCurrentDiagnostics doc expected = do
     diags <- getCurrentDiagnostics doc
     checkDiagnosticsForDoc doc expected diags
 
-checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text)] -> [Diagnostic] -> Session ()
+checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [ExpectedDiagnostic] -> [Diagnostic] -> Session ()
 checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do
-    let expected' = Map.singleton nuri (map (\(ds, c, t, code) -> (ds, c, t, code, Nothing)) expected)
+    let expected' = Map.singleton nuri (map expectedDiagnosticWithNothing expected)
         nuri = toNormalizedUri _uri
     expectDiagnosticsWithTags' (return (_uri, obtained)) expected'
 

hls-test-utils/src/Development/IDE/Test/Diagnostic.hs

@@ -16,10 +16,39 @@ cursorPosition (line,  col) = Position line col
 
 type ErrorMsg = String
 
+
+-- | Expected diagnostics have the following components:
+--
+-- 1. severity
+-- 2. cursor (line and column numbers)
+-- 3. infix of the message
+-- 4. code (e.g. GHC-87543)
+type ExpectedDiagnostic =
+    ( DiagnosticSeverity
+    , Cursor
+    , T.Text
+    , Maybe T.Text
+    )
+
+-- | Expected diagnostics with a tag have the following components:
+--
+-- 1. severity
+-- 2. cursor (line and column numbers)
+-- 3. infix of the message
+-- 4. code (e.g. GHC-87543)
+-- 5. tag (unnecessary or deprecated)
+type ExpectedDiagnosticWithTag =
+    ( DiagnosticSeverity
+    , Cursor
+    , T.Text
+    , Maybe T.Text
+    , Maybe DiagnosticTag
+    )
+
 requireDiagnostic
     :: (Foldable f, Show (f Diagnostic), HasCallStack)
     => f Diagnostic
-    -> (DiagnosticSeverity, Cursor, T.Text, Maybe T.Text, Maybe DiagnosticTag)
+    -> ExpectedDiagnosticWithTag
     -> Maybe ErrorMsg
 requireDiagnostic actuals expected@(severity, cursor, expectedMsg, mbExpectedCode, expectedTag)
     | any match actuals = Nothing

plugins/hls-refactor-plugin/test/Main.hs

@@ -1995,7 +1995,7 @@ suggestImportDisambiguationTests = testGroup "suggest import disambiguation acti
     compareHideFunctionTo = compareTwo "HideFunction.hs"
     withTarget file locs k = runWithExtraFiles "hiding" $ \dir -> do
         doc <- openDoc file "haskell"
-        void $ expectDiagnostics [(file, [(DiagnosticSeverity_Error, loc, "Ambiguous occurrence", Nothing) | loc <- locs])] -- TODO: Give this a proper error
+        void $ expectDiagnostics [(file, [(DiagnosticSeverity_Error, loc, "Ambiguous occurrence", Just "GHC-87543") | loc <- locs])]
         actions <- getAllCodeActions doc
         k dir doc actions
     withHideFunction = withTarget ("HideFunction" <.> "hs")

test/functional/Config.hs

@@ -110,7 +110,7 @@ type instance RuleResult GetTestDiagnostics = ()
 
 expectDiagnosticsFail
   :: HasCallStack
-  => ExpectBroken 'Ideal [(FilePath, [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text)])]
-  -> ExpectBroken 'Current [(FilePath, [(DiagnosticSeverity, Cursor, T.Text, Maybe T.Text)])]
+  => ExpectBroken 'Ideal [(FilePath, [ExpectedDiagnostic])]
+  -> ExpectBroken 'Current [(FilePath, [ExpectedDiagnostic])]
   -> Session ()
 expectDiagnosticsFail _ = expectDiagnostics . unCurrent