Merge branch 'master' into structured-diagnostics

Author: soulomoon

cabal.project

@@ -8,7 +8,7 @@ packages:
          ./hls-test-utils
 
 
-index-state: 2025-05-12T13:26:29Z
+index-state: 2025-06-16T09:44:13Z
 
 tests: True
 test-show-details: direct

docs/support/plugin-support.md

@@ -55,7 +55,7 @@ For example, a plugin to provide a formatter which has itself been abandoned has
 | `hls-explicit-record-fields-plugin`  | 2    |                          |
 | `hls-fourmolu-plugin`                | 2    |                          |
 | `hls-gadt-plugin`                    | 2    |                          |
-| `hls-hlint-plugin`                   | 2    | 9.10.1                   |
+| `hls-hlint-plugin`                   | 2    |                          |
 | `hls-module-name-plugin`             | 2    |                          |
 | `hls-notes-plugin`                   | 2    |                          |
 | `hls-qualify-imported-names-plugin`  | 2    |                          |

flake.lock

@@ -2,7 +2,9 @@
   description = "haskell-language-server development flake";
 
   inputs = {
-    nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable";
+    # Don't use nixpkgs-unstable as aarch64-darwin is currently broken there.
+    # Check again, when https://github.com/NixOS/nixpkgs/pull/414242 is resolved.
+    nixpkgs.url = "github:NixOS/nixpkgs/c742ae7908a82c9bf23ce27bfca92a00e9bcd541";
     flake-utils.url = "github:numtide/flake-utils";
     # For default.nix
     flake-compat = {
@@ -66,6 +68,7 @@
           buildInputs = [
             # Compiler toolchain
             hpkgs.ghc
+            hpkgs.haskell-language-server
             pkgs.haskellPackages.cabal-install
             # Dependencies needed to build some parts of Hackage
             gmp zlib ncurses

flake.nix

@@ -0,0 +1,18 @@
+{-# LANGUAGE RecordWildCards #-}
+module Fields where
+
+data Foo = MkFoo
+  {
+    barr :: String,
+    bazz :: String
+  }
+
+fooUse0 :: Foo -> String
+fooUse0 MkFoo{barr} = "5"
+
+fooUse1 :: Foo -> String
+fooUse1 MkFoo{..} = "6"
+
+fooUse2 :: String -> String -> Foo
+fooUse2 bar baz =
+  MkFoo{..}

ghcide-test/data/references/Fields.hs

@@ -1,7 +1,7 @@
 module Main where
 
 import References
-
+import Fields
 main :: IO ()
 main = return ()
 
@@ -12,3 +12,6 @@ b = a + 1
 
 acc :: Account
 acc = Savings
+
+fooUse3 :: String -> String -> Foo
+fooUse3 bar baz = MkFoo{barr = bar, bazz = baz}

ghcide-test/data/references/Main.hs

@@ -1 +1 @@
-cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References"]}}
+cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References", "Fields"]}}

ghcide-test/data/references/hie.yaml

@@ -33,7 +33,6 @@ import           Test.Hls.Util
 import           Test.Tasty
 import           Test.Tasty.HUnit
 
-
 tests :: TestTree
 tests
   = testGroup "completion"
@@ -61,6 +60,7 @@ completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, Co
 completionTest name src pos expected = testSessionSingleFile name "A.hs" (T.unlines src) $ do
     docId <- openDoc "A.hs" "haskell"
     _ <- waitForDiagnostics
+
     compls <- getAndResolveCompletions docId pos
     let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls]
     let emptyToMaybe x = if T.null x then Nothing else Just x
@@ -211,7 +211,38 @@ localCompletionTests = [
 
         compls <- getCompletions doc (Position 0 15)
         liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"]
-        pure ()
+        pure (),
+    completionTest
+        "polymorphic record dot completion"
+        [ "{-# LANGUAGE OverloadedRecordDot #-}"
+        , "module A () where"
+        , "data Record = Record"
+        , "  { field1 :: Int"
+        , "  , field2 :: Int"
+        , "  }"
+        , -- Without the following, this file doesn't trigger any diagnostics, so completionTest waits forever
+          "triggerDiag :: UnknownType"
+        , "foo record = record.f"
+        ]
+        (Position 7 21)
+        [("field1", CompletionItemKind_Function, "field1", True, False, Nothing)
+        ,("field2", CompletionItemKind_Function, "field2", True, False, Nothing)
+        ],
+    completionTest
+        "qualified polymorphic record dot completion"
+        [ "{-# LANGUAGE OverloadedRecordDot #-}"
+        , "module A () where"
+        , "data Record = Record"
+        , "  { field1 :: Int"
+        , "  , field2 :: Int"
+        , "  }"
+        , "someValue = undefined"
+        , "foo = A.someValue.f"
+        ]
+        (Position 7 19)
+        [("field1", CompletionItemKind_Function, "field1", True, False, Nothing)
+        ,("field2", CompletionItemKind_Function, "field2", True, False, Nothing)
+        ]
     ]
 
 nonLocalCompletionTests :: [TestTree]

ghcide-test/exe/CompletionTests.hs

@@ -33,7 +33,6 @@ module Main (main) where
 import qualified HieDbRetry
 import           Test.Tasty
 import           Test.Tasty.Ingredients.Rerun
-import           Test.Tasty.Runners
 
 import           AsyncTests
 import           BootTests
@@ -71,7 +70,7 @@ import           WatchedFileTests
 main :: IO ()
 main = do
   -- We mess with env vars so run single-threaded.
-  defaultMainWithRerun $ PlusTestOptions mkSequential $ testGroup "ghcide"
+  defaultMainWithRerun $ testGroup "ghcide"
     [ OpenCloseTest.tests
     , InitializeResponseTests.tests
     , CompletionTests.tests
@@ -105,6 +104,3 @@ main = do
     , HieDbRetry.tests
     , ExceptionTests.tests
     ]
-    where
-       PlusTestOptions mkSequential _ =sequentialTestGroup "foo" AllFinish []
-

ghcide-test/exe/Main.hs

@@ -156,6 +156,28 @@ tests = testGroup "references"
                           , ("References.hs", 16, 0)
                           ]
           ]
+        -- Fields.hs does not depend on Main.hs
+        -- so we can only find references in Fields.hs
+        , testGroup "references to record fields"
+          [ referenceTest "references record fields in the same file"
+                          ("Fields.hs", 5, 4)
+                          YesIncludeDeclaration
+                          [ ("Fields.hs", 5, 4)
+                          , ("Fields.hs", 10, 14)
+                          , ("Fields.hs", 13, 14)
+                          ]
+
+          -- Main.hs depends on Fields.hs, so we can find references
+          -- from Main.hs to Fields.hs
+          , referenceTest "references record fields cross modules"
+                          ("Main.hs", 16, 24)
+                          YesIncludeDeclaration
+                          [ ("Fields.hs", 5, 4)
+                          , ("Fields.hs", 10, 14)
+                          , ("Fields.hs", 13, 14)
+                          , ("Main.hs", 16, 24)
+                          ]
+          ]
     ]
 
 -- | When we ask for all references to symbol "foo", should the declaration "foo

ghcide-test/exe/ReferenceTests.hs

@@ -57,7 +57,7 @@ library
     , deepseq
     , dependent-map
     , dependent-sum
-    , Diff                         ^>=0.5
+    , Diff                         ^>=0.5 || ^>=1.0.0
     , directory
     , dlist
     , enummapset
@@ -75,7 +75,7 @@ library
     , hashable
     , hie-bios                     ^>=0.15.0
     , hie-compat                   ^>=0.3.0.0
-    , hiedb                        ^>= 0.6.0.2
+    , hiedb                        ^>= 0.7.0.0
     , hls-graph                    == 2.11.0.0
     , hls-plugin-api               == 2.11.0.0
     , implicit-hie                 >= 0.1.4.0 && < 0.1.5

ghcide/ghcide.cabal

@@ -223,7 +223,7 @@ instance Pretty Log where
 
 -- | Bump this version number when making changes to the format of the data stored in hiedb
 hiedbDataVersion :: String
-hiedbDataVersion = "1"
+hiedbDataVersion = "2"
 
 data CacheDirs = CacheDirs
   { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}
@@ -956,6 +956,8 @@ CallStack (from HasCallStack):
   expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst
 ```
 
+and many more.
+
 To mitigate this, we set the cache directory for each component dependent
 on the components of the current `HscEnv`, additionally to the component options
 of the respective components.

ghcide/session-loader/Development/IDE/Session.hs

@@ -17,21 +17,43 @@ module Development.IDE.GHC.Compat.Error (
   DriverMessage (..),
   -- * General Diagnostics
   Diagnostic(..),
-  -- * Prisms for error selection
+  -- * Prisms and lenses for error selection
   _TcRnMessage,
+  _TcRnMessageWithCtx,
   _GhcPsMessage,
   _GhcDsMessage,
   _GhcDriverMessage,
+  _TcRnMissingSignature,
+  _TcRnSolverReport,
+  _TcRnMessageWithInfo,
+  reportContextL,
+  reportContentL,
+  _MismatchMessage,
+  _TypeEqMismatchActual,
+  _TypeEqMismatchExpected,
   ) where
 
 import           Control.Lens
+import           Development.IDE.GHC.Compat (Type)
 import           GHC.Driver.Errors.Types
 import           GHC.HsToCore.Errors.Types
 import           GHC.Tc.Errors.Types
 import           GHC.Types.Error
 
-_TcRnMessage :: Prism' GhcMessage TcRnMessage
-_TcRnMessage = prism' GhcTcRnMessage (\case
+-- | Some 'TcRnMessage's are nested in other constructors for additional context.
+-- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'.
+-- However, in most occasions you don't need the additional context and you just want
+-- the error message. @'_TcRnMessage'@ recursively unwraps these constructors,
+-- until there are no more constructors with additional context.
+--
+-- Use @'_TcRnMessageWithCtx'@ if you need the additional context. You can always
+-- strip it later using @'stripTcRnMessageContext'@.
+--
+_TcRnMessage :: Fold GhcMessage TcRnMessage
+_TcRnMessage = _TcRnMessageWithCtx . to stripTcRnMessageContext
+
+_TcRnMessageWithCtx :: Prism' GhcMessage TcRnMessage
+_TcRnMessageWithCtx = prism' GhcTcRnMessage (\case
   GhcTcRnMessage tcRnMsg -> Just tcRnMsg
   _ -> Nothing)
 
@@ -66,3 +88,38 @@ stripTcRnMessageContext = \case
 
 msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e
 msgEnvelopeErrorL = lens errMsgDiagnostic (\envelope e -> envelope { errMsgDiagnostic = e } )
+
+makePrisms ''TcRnMessage
+
+makeLensesWith
+    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))
+    ''SolverReportWithCtxt
+
+-- | Focus 'MismatchMsg' from 'TcSolverReportMsg'. Currently, 'MismatchMsg' can be
+-- extracted from 'CannotUnifyVariable' and 'Mismatch' constructors.
+_MismatchMessage :: Traversal' TcSolverReportMsg MismatchMsg
+_MismatchMessage focus (Mismatch msg t a c) = (\msg' -> Mismatch msg' t a c) <$> focus msg
+_MismatchMessage focus (CannotUnifyVariable msg a) = flip CannotUnifyVariable a <$> focus msg
+_MismatchMessage _ report = pure report
+
+-- | Focus 'teq_mismatch_expected' from 'TypeEqMismatch'.
+_TypeEqMismatchExpected :: Traversal' MismatchMsg Type
+#if MIN_VERSION_ghc(9,12,0)
+_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ expected _ _ _) =
+    (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected
+#else
+_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ _ expected _ _ _) =
+    (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected
+#endif
+_TypeEqMismatchExpected _ mismatch = pure mismatch
+
+-- | Focus 'teq_mismatch_actual' from 'TypeEqMismatch'.
+_TypeEqMismatchActual :: Traversal' MismatchMsg Type
+#if MIN_VERSION_ghc(9,12,0)
+_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ actual _ _) =
+    (\actual' -> mismatch { teq_mismatch_actual = actual' }) <$> focus actual
+#else
+_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ _ actual _ _) =
+    (\actual' -> mismatch { teq_mismatch_expected = actual' }) <$> focus actual
+#endif
+_TypeEqMismatchActual _ mismatch = pure mismatch

ghcide/src/Development/IDE/GHC/Compat/Error.hs

@@ -878,7 +878,9 @@ getCompletionPrefixFromRope pos@(Position l c) ropetext =
           [] -> Nothing
           (x:xs) -> do
             let modParts = reverse $ filter (not .T.null) xs
-                modName = T.intercalate "." modParts
+                -- Must check the prefix is a valid module name, else record dot accesses treat
+                -- the record name as a qualName for search and generated imports
+                modName = if all (isUpper . T.head) modParts then T.intercalate "." modParts else ""
             return $ PosPrefixInfo { fullLine = curLine, prefixScope = modName, prefixText = x, cursorPos = pos }
 
 completionPrefixPos :: PosPrefixInfo -> Position