hie-files: Record location of filled in default method bindings

This is useful for hie files to reconstruct the evidence that default methods
depend on.

6 files changed, 190 insertions, 44 deletions

diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index c99beb861e..3067861431 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -1758,7 +1758,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
 
     tc_default sel_id (Just (dm_name, _))
-      = do { (meth_bind, inline_prags) <- mkDefMethBind dfun_id clas sel_id dm_name
+      = do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name
            ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
                           dfun_ev_binds is_derived hs_sig_fn
                           spec_inst_prags inline_prags
@@ -2105,7 +2105,7 @@ mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
          | L inst_loc (SpecPrag _       wrap inl) <- spec_inst_prags]
 
 
-mkDefMethBind :: DFunId -> Class -> Id -> Name
+mkDefMethBind :: SrcSpan -> DFunId -> Class -> Id -> Name
               -> TcM (LHsBind GhcRn, [LSig GhcRn])
 -- The is a default method (vanailla or generic) defined in the class
 -- So make a binding   op = $dmop @t1 @t2
@@ -2113,7 +2113,7 @@ mkDefMethBind :: DFunId -> Class -> Id -> Name
 -- and t1,t2 are the instance types.
 -- See Note [Default methods in instances] for why we use
 -- visible type application here
-mkDefMethBind dfun_id clas sel_id dm_name
+mkDefMethBind loc dfun_id clas sel_id dm_name
   = do  { logger <- getLogger
         ; dm_id <- tcLookupId dm_name
         ; let inline_prag = idInlinePragma dm_id
@@ -2128,8 +2128,9 @@ mkDefMethBind dfun_id clas sel_id dm_name
               visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
                                       , tyConBinderArgFlag tcb /= Inferred ]
               rhs  = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
-              bind = noLocA $ mkTopFunBind Generated fn $
-                             [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
+              bind = L (noAnnSrcSpan loc)
+                    $ mkTopFunBind Generated fn
+                        [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
 
         ; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body"
                    FormatHaskell
diff --git a/testsuite/tests/ghci/scripts/T16575.stdout b/testsuite/tests/ghci/scripts/T16575.stdout
index 833fb02d80..b907a52653 100644
--- a/testsuite/tests/ghci/scripts/T16575.stdout
+++ b/testsuite/tests/ghci/scripts/T16575.stdout
@@ -1,6 +1,9 @@
 Collecting type info for 1 module(s) ... 
 T16575.hs:(4,15)-(4,18): GHC.Types.Int -> Ghost.X -> GHC.Show.ShowS
+T16575.hs:(4,15)-(4,18): Ghost.X -> GHC.Base.String
+T16575.hs:(4,15)-(4,18): [Ghost.X] -> GHC.Show.ShowS
 T16575.hs:(7,7)-(7,8): Ghost.X -> Ghost.X -> GHC.Types.Bool
+T16575.hs:(6,10)-(6,13): Ghost.X -> Ghost.X -> GHC.Types.Bool
 T16575.hs:(4,15)-(4,18): GHC.Show.Show Ghost.X
 T16575.hs:(4,15)-(4,18): ([Ghost.X] -> GHC.Show.ShowS) -> GHC.Show.Show Ghost.X
 T16575.hs:(4,15)-(4,18): (Ghost.X -> GHC.Base.String) -> ([Ghost.X] -> GHC.Show.ShowS) -> GHC.Show.Show Ghost.X
diff --git a/testsuite/tests/hiefile/should_run/T20341.hs b/testsuite/tests/hiefile/should_run/T20341.hs
new file mode 100644
index 0000000000..22b0c1a564
--- /dev/null
+++ b/testsuite/tests/hiefile/should_run/T20341.hs
@@ -0,0 +1,104 @@
+{-# language DeriveAnyClass #-}
+{-# language DefaultSignatures #-}
+{-# language DeriveGeneric #-}
+
+module Main where
+
+import System.Environment
+import Data.Tree
+import GHC.Types.Name.Cache
+import GHC.Types.SrcLoc
+import GHC.Types.Unique.Supply
+import GHC.Types.Name
+import GHC.Utils.Outputable                 ( Outputable, renderWithContext, ppr, defaultUserStyle, text)
+import GHC.Iface.Ext.Binary
+import GHC.Iface.Ext.Types
+import GHC.Iface.Ext.Utils
+
+import GHC.Driver.Session
+import GHC.SysTools
+
+import qualified Data.Map as M
+import Data.Foldable
+
+import GHC.Generics
+
+class ToJSON a where
+  foo :: a -> String
+  default foo :: Show a => a -> String
+  foo x = show x
+
+data T = MkT { fieldName :: Bool }
+  deriving (Show, ToJSON)
+
+
+g :: String
+g = foo (MkT True)
+--   ^ this is point
+
+h :: String
+h = show (MkT True)
+--   ^ this is point'
+
+point :: (Int, Int)
+point = (36,6)
+
+point' :: (Int, Int)
+point' = (40,6)
+
+makeNc :: IO NameCache
+makeNc = initNameCache 'z' []
+
+dynFlagsForPrinting :: String -> IO DynFlags
+dynFlagsForPrinting libdir = do
+  systemSettings <- initSysTools libdir
+  return $ defaultDynFlags systemSettings (LlvmConfig [] [])
+
+selectPoint' :: HieFile -> (Int,Int) -> HieAST Int
+selectPoint' hf loc =
+  maybe (error "point not found") id $ selectPoint hf loc
+
+main = do
+  libdir:_ <- getArgs
+  df <- dynFlagsForPrinting libdir
+  nc <- makeNc
+  hfr <- readHieFile nc "T20341.hie"
+  let hf = hie_file_result hfr
+      asts = getAsts $ hie_asts hf
+      [ast] = M.elems asts
+      refmap = generateReferencesMap $ asts
+      expandType = text . renderHieType df .
+        flip recoverFullType (hie_types hf)
+      pretty = unlines . (++["└"]) . ("┌":) . map ("│ "++) . lines
+      pprint = pretty . render
+      render :: forall a. Outputable a => a -> String
+      render = renderWithContext (initSDocContext df sty) . ppr
+      sty = defaultUserStyle
+  putStr $ "At " ++ show point ++ ", got evidence: "
+  let trees = getEvidenceTreesAtPoint hf refmap point
+      ptrees = fmap (pprint . fmap expandType) <$> trees
+  -- Print the evidence tree at point - it should include $fToJSONT
+  putStr $ drawForest ptrees
+
+  -- Get the definition location of $fToJSONT
+  let loc = evidenceSpan $ head $ last $ levels $ head trees
+  print loc
+
+  -- Find the ast of the definition of $fToJSONT
+  let Just fToJSONTAst= selectLargestContainedBy loc ast
+
+  -- Print the evidence tree at point' - it should include $fShowT
+  let trees' = getEvidenceTreesAtPoint hf refmap point'
+      ptrees' = fmap (pprint . fmap expandType) <$> trees'
+  -- Print the evidence tree at point' - it should include $ShowT
+  putStr $ drawForest ptrees'
+
+  -- Get the name of $dShow = $fShowT
+  let dShowT = evidenceVar $ rootLabel $ head trees'
+
+  -- Finally ensure that the definition of $fToJSONT contains a reference to $dShowT
+  let isMember = M.member (Right dShowT) $ sourcedNodeIdents $ sourcedNodeInfo fToJSONTAst
+  if isMember
+  then putStrLn "$dShow was found in the definition of $fToJSONT"
+  else putStrLn "ERROR: $dShow was NOT found in the definition of $fToJSONT"
+
diff --git a/testsuite/tests/hiefile/should_run/T20341.stdout b/testsuite/tests/hiefile/should_run/T20341.stdout
new file mode 100644
index 0000000000..45b31bd95e
--- /dev/null
+++ b/testsuite/tests/hiefile/should_run/T20341.stdout
@@ -0,0 +1,34 @@
+At (36,6), got evidence: ┌
+│ $dToJSON at T20341.hs:1:1, of type: ToJSON T
+│     is an evidence variable bound by a let, depending on: [$fToJSONT]
+│           with scope: ModuleScope
+│           
+│     Defined at <no location info>
+└
+|
+`- ┌
+   │ $fToJSONT at T20341.hs:32:19-24, of type: ToJSON T
+   │     is an evidence variable bound by an instance of class ToJSON
+   │           with scope: ModuleScope
+   │           
+   │     Defined at T20341.hs:32:19
+   └
+
+SrcSpanOneLine "T20341.hs" 32 19 25
+┌
+│ $dShow at T20341.hs:1:1, of type: Show T
+│     is an evidence variable bound by a let, depending on: [$fShowT]
+│           with scope: ModuleScope
+│           
+│     Defined at <no location info>
+└
+|
+`- ┌
+   │ $fShowT at T20341.hs:32:13-16, of type: Show T
+   │     is an evidence variable bound by an instance of class Show
+   │           with scope: ModuleScope
+   │           
+   │     Defined at T20341.hs:32:13
+   └
+
+$dShow was found in the definition of $fToJSONT
diff --git a/testsuite/tests/hiefile/should_run/all.T b/testsuite/tests/hiefile/should_run/all.T
index 55dc8d1722..f734e3c12e 100644
--- a/testsuite/tests/hiefile/should_run/all.T
+++ b/testsuite/tests/hiefile/should_run/all.T
@@ -1,2 +1,3 @@
 test('PatTypes', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info'])
 test('HieQueries', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info'])
+test('T20341', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info'])
diff --git a/testsuite/tests/profiling/should_run/ioprof.prof.sample b/testsuite/tests/profiling/should_run/ioprof.prof.sample
index 103207d8ca..f33134f243 100644
--- a/testsuite/tests/profiling/should_run/ioprof.prof.sample
+++ b/testsuite/tests/profiling/should_run/ioprof.prof.sample
@@ -1,54 +1,57 @@
-	Mon May 23 13:50 2022 Time and Allocation Profiling Report  (Final)
+	Wed Jul  6 01:06 2022 Time and Allocation Profiling Report  (Final)
 
 	   ioprof +RTS -hc -p -RTS
 
 	total time  =        0.00 secs   (0 ticks @ 1000 us, 1 processor)
-	total alloc =     129,248 bytes  (excludes profiling overheads)
+	total alloc =     130,792 bytes  (excludes profiling overheads)
 
 COST CENTRE MODULE           SRC                 %time %alloc
 
-CAF         Main             <entire-module>       0.0    1.1
-main        Main             ioprof.hs:28:1-43     0.0    6.8
-errorM.\    Main             ioprof.hs:23:22-28    0.0   56.8
-CAF         GHC.IO.Handle.FD <entire-module>       0.0   26.9
+CAF         GHC.IO.Handle.FD <entire-module>       0.0   26.6
 CAF         GHC.IO.Exception <entire-module>       0.0    1.0
 CAF         GHC.IO.Encoding  <entire-module>       0.0    2.3
 CAF         GHC.Exception    <entire-module>       0.0    3.0
+CAF         Main             <entire-module>       0.0    1.1
+main        Main             ioprof.hs:28:1-43     0.0    6.7
+errorM.\    Main             ioprof.hs:23:22-28    0.0   57.3
 
 
                                                                                   individual      inherited
 COST CENTRE    MODULE                SRC                       no.     entries  %time %alloc   %time %alloc
 
-MAIN           MAIN                  <built-in>                129           0    0.0    0.5     0.0  100.0
- CAF           GHC.Conc.Signal       <entire-module>           233           0    0.0    0.5     0.0    0.5
- CAF           GHC.Conc.Sync         <entire-module>           232           0    0.0    0.5     0.0    0.5
- CAF           GHC.Exception         <entire-module>           215           0    0.0    3.0     0.0    3.0
- CAF           GHC.IO.Encoding       <entire-module>           199           0    0.0    2.3     0.0    2.3
- CAF           GHC.IO.Encoding.Iconv <entire-module>           197           0    0.0    0.2     0.0    0.2
- CAF           GHC.IO.Exception      <entire-module>           191           0    0.0    1.0     0.0    1.0
- CAF           GHC.IO.Handle.FD      <entire-module>           188           0    0.0   26.9     0.0   26.9
- CAF           GHC.Stack.CCS         <entire-module>           167           0    0.0    0.2     0.0    0.2
- CAF           GHC.Weak.Finalize     <entire-module>           158           0    0.0    0.0     0.0    0.0
- CAF           Main                  <entire-module>           136           0    0.0    1.1     0.0    1.1
-  <*>          Main                  ioprof.hs:20:5-14         261           1    0.0    0.0     0.0    0.0
-  fmap         Main                  ioprof.hs:16:5-16         269           1    0.0    0.0     0.0    0.0
-  main         Main                  ioprof.hs:28:1-43         258           1    0.0    0.0     0.0    0.0
- main          Main                  ioprof.hs:28:1-43         259           0    0.0    6.8     0.0   63.7
-  bar          Main                  ioprof.hs:31:1-20         260           1    0.0    0.1     0.0    0.2
-   foo         Main                  ioprof.hs:34:1-16         275           1    0.0    0.0     0.0    0.0
-    errorM     Main                  ioprof.hs:23:1-28         276           1    0.0    0.0     0.0    0.0
-   <*>         Main                  ioprof.hs:20:5-14         262           0    0.0    0.0     0.0    0.0
-    >>=        Main                  ioprof.hs:(11,3)-(12,50)  263           1    0.0    0.0     0.0    0.0
-   fmap        Main                  ioprof.hs:16:5-16         270           0    0.0    0.0     0.0    0.0
-    >>=        Main                  ioprof.hs:(11,3)-(12,50)  271           1    0.0    0.0     0.0    0.0
-  runM         Main                  ioprof.hs:26:1-37         264           1    0.0    0.0     0.0   56.8
-   bar         Main                  ioprof.hs:31:1-20         265           0    0.0    0.0     0.0   56.8
-    <*>        Main                  ioprof.hs:20:5-14         266           0    0.0    0.0     0.0    0.0
-     >>=       Main                  ioprof.hs:(11,3)-(12,50)  267           0    0.0    0.0     0.0    0.0
-      >>=.\    Main                  ioprof.hs:(11,27)-(12,50) 268           1    0.0    0.0     0.0    0.0
-    fmap       Main                  ioprof.hs:16:5-16         272           0    0.0    0.0     0.0    0.0
-     >>=       Main                  ioprof.hs:(11,3)-(12,50)  273           0    0.0    0.0     0.0    0.0
-      >>=.\    Main                  ioprof.hs:(11,27)-(12,50) 274           1    0.0    0.0     0.0    0.0
-    foo        Main                  ioprof.hs:34:1-16         277           0    0.0    0.0     0.0   56.8
-     errorM    Main                  ioprof.hs:23:1-28         278           0    0.0    0.0     0.0   56.8
-      errorM.\ Main                  ioprof.hs:23:22-28        279           1    0.0   56.8     0.0   56.8
+MAIN           MAIN                  <built-in>                131           0    0.0    0.5     0.0  100.0
+ CAF           Main                  <entire-module>           261           0    0.0    1.1     0.0    1.1
+  <*>          Main                  ioprof.hs:20:5-14         267           1    0.0    0.0     0.0    0.0
+  fmap         Main                  ioprof.hs:16:5-16         276           1    0.0    0.0     0.0    0.0
+  liftA2       Main                  ioprof.hs:18:10-26        265           1    0.0    0.0     0.0    0.0
+  main         Main                  ioprof.hs:28:1-43         262           1    0.0    0.0     0.0    0.0
+ CAF           GHC.Conc.Signal       <entire-module>           256           0    0.0    0.5     0.0    0.5
+ CAF           GHC.Conc.Sync         <entire-module>           254           0    0.0    0.5     0.0    0.5
+ CAF           GHC.Exception         <entire-module>           252           0    0.0    3.0     0.0    3.0
+ CAF           GHC.IO.Encoding       <entire-module>           243           0    0.0    2.3     0.0    2.3
+ CAF           GHC.IO.Encoding.Iconv <entire-module>           240           0    0.0    0.2     0.0    0.2
+ CAF           GHC.IO.Exception      <entire-module>           225           0    0.0    1.0     0.0    1.0
+ CAF           GHC.IO.Handle.FD      <entire-module>           219           0    0.0   26.6     0.0   26.6
+ CAF           GHC.Stack.CCS         <entire-module>           195           0    0.0    0.2     0.0    0.2
+ CAF           GHC.Weak.Finalize     <entire-module>           184           0    0.0    0.0     0.0    0.0
+ main          Main                  ioprof.hs:28:1-43         263           0    0.0    6.7     0.0   64.2
+  bar          Main                  ioprof.hs:31:1-20         264           1    0.0    0.1     0.0    0.2
+   foo         Main                  ioprof.hs:34:1-16         282           1    0.0    0.0     0.0    0.0
+    errorM     Main                  ioprof.hs:23:1-28         283           1    0.0    0.0     0.0    0.0
+   liftA2      Main                  ioprof.hs:18:10-26        266           0    0.0    0.1     0.0    0.1
+    <*>        Main                  ioprof.hs:20:5-14         268           0    0.0    0.0     0.0    0.0
+     >>=       Main                  ioprof.hs:(11,3)-(12,50)  269           1    0.0    0.0     0.0    0.0
+    fmap       Main                  ioprof.hs:16:5-16         277           0    0.0    0.0     0.0    0.0
+     >>=       Main                  ioprof.hs:(11,3)-(12,50)  278           1    0.0    0.0     0.0    0.0
+  runM         Main                  ioprof.hs:26:1-37         270           1    0.0    0.0     0.0   57.3
+   bar         Main                  ioprof.hs:31:1-20         271           0    0.0    0.0     0.0   57.3
+    foo        Main                  ioprof.hs:34:1-16         284           0    0.0    0.0     0.0   57.3
+     errorM    Main                  ioprof.hs:23:1-28         285           0    0.0    0.0     0.0   57.3
+      errorM.\ Main                  ioprof.hs:23:22-28        286           1    0.0   57.3     0.0   57.3
+    liftA2     Main                  ioprof.hs:18:10-26        272           0    0.0    0.0     0.0    0.0
+     <*>       Main                  ioprof.hs:20:5-14         273           0    0.0    0.0     0.0    0.0
+      >>=      Main                  ioprof.hs:(11,3)-(12,50)  274           0    0.0    0.0     0.0    0.0
+       >>=.\   Main                  ioprof.hs:(11,27)-(12,50) 275           1    0.0    0.0     0.0    0.0
+     fmap      Main                  ioprof.hs:16:5-16         279           0    0.0    0.0     0.0    0.0
+      >>=      Main                  ioprof.hs:(11,3)-(12,50)  280           0    0.0    0.0     0.0    0.0
+       >>=.\   Main                  ioprof.hs:(11,27)-(12,50) 281           1    0.0    0.0     0.0    0.0