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.

3 files changed, 139 insertions, 0 deletions

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'])