hie-files: Fix scopes for deriving clauses and instance signatures (#18425)

5 files changed, 29 insertions, 7 deletions

diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 43cd29bc1c..affe0e7ca4 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1583,7 +1583,7 @@ instance ToHie (Located [LocatedAn NoEpAnns (HsDerivingClause GhcRn)]) where
 instance ToHie (LocatedAn NoEpAnns (HsDerivingClause GhcRn)) where
   toHie (L span cl) = concatM $ makeNodeA cl span : case cl of
       HsDerivingClause _ strat dct ->
-        [ toHie strat
+        [ toHie (RS (mkLScopeA dct) <$> strat)
         , toHie dct
         ]
 
@@ -1592,12 +1592,12 @@ instance ToHie (LocatedC (DerivClauseTys GhcRn)) where
       DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ]
       DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ]
 
-instance ToHie (LocatedAn NoEpAnns (DerivStrategy GhcRn)) where
-  toHie (L span strat) = concatM $ makeNodeA strat span : case strat of
+instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where
+  toHie (RS sc (L span strat)) = concatM $ makeNodeA strat span : case strat of
       StockStrategy _ -> []
       AnyclassStrategy _ -> []
       NewtypeStrategy _ -> []
-      ViaStrategy s -> [ toHie (TS (ResolvedScopes []) s) ]
+      ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ]
 
 instance ToHie (LocatedP OverlapMode) where
   toHie (L span _) = locOnly (locA span)
@@ -1970,7 +1970,7 @@ instance ToHie (LocatedA (DerivDecl GhcRn)) where
   toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
       DerivDecl _ typ strat overlap ->
         [ toHie $ TS (ResolvedScopes []) typ
-        , toHie strat
+        , toHie $ (RS (mkScopeA span) <$> strat)
         , toHie overlap
         ]
 
diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs
index 20d047d150..aece9ed044 100644
--- a/compiler/GHC/Iface/Ext/Utils.hs
+++ b/compiler/GHC/Iface/Ext/Utils.hs
@@ -296,8 +296,9 @@ getNameBindingInClass
   -> Maybe Span
 getNameBindingInClass n sp asts = do
   ast <- M.lookup (HiePath (srcSpanFile sp)) asts
+  clsNode <- selectLargestContainedBy sp ast
   getFirst $ foldMap First $ do
-    child <- flattenAst ast
+    child <- flattenAst clsNode
     dets <- maybeToList
       $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child
     let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
diff --git a/testsuite/tests/hiefile/should_compile/T18425.hs b/testsuite/tests/hiefile/should_compile/T18425.hs
new file mode 100644
index 0000000000..dae38f64cf
--- /dev/null
+++ b/testsuite/tests/hiefile/should_compile/T18425.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+module Bug where
+
+newtype List a = MkList [a]
+deriving via forall a. [a] instance Eq a => Eq (List a)
+
+class C a where
+  m :: forall b. a -> b -> b
+  m _ = undefined @_ @a `seq` id @b
+
+instance C [a] where
+  m :: forall b. [a] -> b -> b
+  m _ = undefined @_ @a `seq` id @b
diff --git a/testsuite/tests/hiefile/should_compile/T18425.stderr b/testsuite/tests/hiefile/should_compile/T18425.stderr
new file mode 100644
index 0000000000..f31d37d99f
--- /dev/null
+++ b/testsuite/tests/hiefile/should_compile/T18425.stderr
@@ -0,0 +1,2 @@
+Got valid scopes
+Got no roundtrip errors
diff --git a/testsuite/tests/hiefile/should_compile/all.T b/testsuite/tests/hiefile/should_compile/all.T
index 86fbd6e20f..73b98a1f94 100644
--- a/testsuite/tests/hiefile/should_compile/all.T
+++ b/testsuite/tests/hiefile/should_compile/all.T
@@ -20,4 +20,5 @@ test('CPP',          normal,                   compile, ['-fno-code -fwrite-ide-
 test('Constructors', normal,                   compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
 test('Scopes',       normal,                   compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
 # See https://gitlab.haskell.org/ghc/ghc/-/issues/18425 and https://gitlab.haskell.org/ghc/ghc/-/merge_requests/2464#note_301989
-test('ScopesBug',    expect_broken(18425),     compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
\ No newline at end of file
+test('ScopesBug',    expect_broken(18425),     compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
+test('T18425',       normal,     compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])