diff options
| -rw-r--r-- | compiler/GHC/Tc/TyCl/Instance.hs | 11 | ||||
| -rw-r--r-- | testsuite/tests/ghci/scripts/T16575.stdout | 3 | ||||
| -rw-r--r-- | testsuite/tests/hiefile/should_run/T20341.hs | 104 | ||||
| -rw-r--r-- | testsuite/tests/hiefile/should_run/T20341.stdout | 34 | ||||
| -rw-r--r-- | testsuite/tests/hiefile/should_run/all.T | 1 | ||||
| -rw-r--r-- | testsuite/tests/profiling/should_run/ioprof.prof.sample | 81 |
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 |