Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 1a3afd5c by Apoorv Ingle at 2025-11-24T15:50:29-06:00 - look through applications to check if we need deepsubsumption - Tests cleanup - - - - - 20 changed files: - compiler/GHC/CmmToAsm.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Hs.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Utils/Monad.hs - − testsuite/tests/deSugar/should_compile/T10662 - − testsuite/tests/ghci.debugger/Do - − testsuite/tests/ghci.debugger/Do.hs - − testsuite/tests/ghci.debugger/T25996.hs - + testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs - − testsuite/tests/typecheck/should_compile/T25996.hs - testsuite/tests/typecheck/should_compile/all.T - − testsuite/tests/typecheck/should_fail/T25970.hs - − testsuite/tests/typecheck/should_fail/T25996.hs - testsuite/tests/typecheck/should_fail/T7857.stderr - testsuite/tests/typecheck/should_fail/tcfail181.stderr Changes: ===================================== compiler/GHC/CmmToAsm.hs ===================================== @@ -1,4 +1,3 @@ -{-# LANGUAGE DeepSubsumption #-} -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1993-2004 ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -8,7 +8,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeepSubsumption #-} module GHC.Driver.Downsweep ( downsweep , downsweepThunk ===================================== compiler/GHC/Hs.hs ===================================== @@ -36,8 +36,7 @@ module GHC.Hs ( module GHC.Parser.Annotation, HsModule(..), AnnsModule(..), - HsParsedModule(..), XModulePs(..), - + HsParsedModule(..), XModulePs(..) ) where -- friends: ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1157,7 +1157,8 @@ the typechecker: * HsDo, where we give the SrcSpan of the entire do block to each ApplicativeStmt. * Expanded (via ExpandedThingRn) ExplicitList{}, where we give the SrcSpan of the original - list expression to the 'fromListN' call. + list expression to the expanded expression. The 'fromListN' is assigned + a generated location span In order for the implicit function calls to not be confused for actual occurrences of functions in the source code, most of this extra information ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -8,7 +8,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeepSubsumption #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage {-# LANGUAGE InstanceSigs #-} ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -53,6 +53,7 @@ import GHC.Builtin.PrimOps( tagToEnumKey ) import GHC.Builtin.Names import GHC.Types.Var +import GHC.Types.Id ( isDataConId ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Reader @@ -186,15 +187,14 @@ Note [Instantiation variables are short lived] tcExprSigma :: Bool -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) tcExprSigma inst rn_expr = do { (fun@(rn_fun,fun_lspan), rn_args) <- splitHsApps rn_expr - -- ; ds_flag <- getDeepSubsumptionFlag_DataConHead rn_fun - -- ; do_ql <- wantQuickLook rn_fun ; (tc_fun, fun_sigma) <- tcInferAppHead fun ; code_orig <- getSrcCodeOrigin ; let fun_orig | not (isGeneratedSrcSpan fun_lspan) = exprCtOrigin rn_fun | otherwise = srcCodeOriginCtOrigin rn_fun code_orig - ; traceTc "tcExprSigma" (vcat [text "rn_expr:" <+> ppr rn_expr, ppr tc_fun]) + ; traceTc "tcExprSigma" (vcat [ text "rn_expr:" <+> ppr rn_expr + , text "tc_fun" <+> ppr tc_fun ]) ; (inst_args, app_res_sigma) <- tcInstFun DoQL inst (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigma rn_args ; tc_args <- tcValArgs DoQL (rn_fun, fun_lspan) inst_args ; let tc_expr = rebuildHsApps (tc_fun, fun_lspan) tc_args @@ -486,11 +486,31 @@ getDeepSubsumptionFlag_DataConHead app_head = ; return $ if | user_ds -> Deep DeepSub - | XExpr (ConLikeTc (RealDataCon {})) <- app_head - -> Deep TopSub | otherwise - -> Shallow - } + -> go app_head + } + where + go :: HsExpr GhcTc -> DeepSubsumptionFlag + go app_head + | XExpr (ConLikeTc (RealDataCon {})) <- app_head + = Deep TopSub + | XExpr (ExpandedThingTc _ f) <- app_head + = go f + | XExpr (WrapExpr _ f) <- app_head + = go f + | HsVar _ f <- app_head + , isDataConId (unLoc f) + = Deep TopSub + | HsApp _ f _ <- app_head + = go (unLoc f) + | HsAppType _ f _ <- app_head + = go (unLoc f) + | OpApp _ _ f _ <- app_head + = go (unLoc f) + | HsPar _ f <- app_head + = go (unLoc f) + | otherwise + = Shallow finishApp :: (HsExpr GhcTc, SrcSpan) -> [HsExprArg 'TcpTc] -> TcRhoType -> HsWrapper ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -767,6 +767,8 @@ tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty) tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcXExpr (ExpandedThingRn o e) res_ty = mkExpandedTc o <$> -- necessary for hpc ticks + -- Need to call tcExpr and not tcApp + -- as e can be let statements which tcApp cannot gracefully handle tcExpr e res_ty -- For record selection, same as HsVar case ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -465,9 +465,11 @@ tcInferAppHead_maybe fun = case fun of HsVar _ nm -> Just <$> tcInferId nm XExpr (HsRecSelRn f) -> Just <$> tcInferRecSelId f - XExpr (ExpandedThingRn o e) -> Just <$> (addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $ -- ANI: TODO this is fishy.. - -- We do not want to instantiate c.f. T19167 - tcExprSigma False e + XExpr (ExpandedThingRn o e) -> Just <$> (addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $ + -- ANI: TODO this is addExpansionErrCtxt is fishy.. + -- We do not want to instantiate the type of the head + -- c.f. T19167 + (\ (x, y) -> (mkExpandedTc o x, y)) <$> tcExprSigma False e ) ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty HsOverLit _ lit -> Just <$> tcInferOverLit lit ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -63,7 +63,7 @@ module GHC.Tc.Utils.Monad( -- * Error management getSrcCodeOrigin, getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, - inGeneratedCode, -- setInGeneratedCode, + inGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, getErrsVar, setErrsVar, ===================================== testsuite/tests/deSugar/should_compile/T10662 deleted ===================================== Binary files a/testsuite/tests/deSugar/should_compile/T10662 and /dev/null differ ===================================== testsuite/tests/ghci.debugger/Do deleted ===================================== Binary files a/testsuite/tests/ghci.debugger/Do and /dev/null differ ===================================== testsuite/tests/ghci.debugger/Do.hs deleted ===================================== @@ -1,6 +0,0 @@ - -module Main where - -main :: IO () -main = do putStrLn "Hello" - putStrLn "World" ===================================== testsuite/tests/ghci.debugger/T25996.hs deleted ===================================== @@ -1,17 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Wno-unused-local-binds #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} - -main :: IO () -main = do - pure () - where - biz :: IO () - biz = do - pure (10 :: Integer) - pure () - -biz' :: IO () -biz' = do - pure (10 :: Integer) - pure () ===================================== testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs ===================================== @@ -0,0 +1,10 @@ +module Test where + + +qqqq :: [String] +qqqq = (show (1 :: Int) :) $ ["2"] + +main :: IO () +main = do + putStrLn "abc" + putStrLn $ concat qqqq ===================================== testsuite/tests/typecheck/should_compile/T25996.hs deleted ===================================== @@ -1,20 +0,0 @@ - -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Wno-unused-local-binds #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} - -module T25996 where - -main :: IO () -main = do - pure () - where - biz :: IO () - biz = do - pure (10 :: Integer) - pure () - -biz' :: IO () -biz' = do - pure (10 :: Integer) - pure () ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -658,8 +658,8 @@ def onlyHsParLocs(x): """ ls = x.split("\n") filteredLines = (loc.strip() for (loc,hspar) in zip(ls,ls[5:]) - if hspar.strip().startswith("(HsPar") - and not "<no location info>" in loc) + if hspar.strip().startswith("(HsPar") + and not "<no location info>" in loc) return '\n'.join(filteredLines) test('T15242', normalise_errmsg_fun(onlyHsParLocs), compile, ['']) test('T15431', normal, compile, ['']) @@ -957,3 +957,4 @@ test('T17705', normal, compile, ['']) test('T14745', normal, compile, ['']) test('T26451', normal, compile, ['']) test('T26582', normal, compile, ['']) +test('ExpansionQLIm', normal, compile, ['']) ===================================== testsuite/tests/typecheck/should_fail/T25970.hs deleted ===================================== @@ -1,18 +0,0 @@ - -{-# LANGUAGE TypeFamilies #-} -module T25970 where - -y :: IO () -y = putStrLn "y" - - -type family K a where - K a = Bool - -x :: IO (K b) -x = do - y - pure () -- The error should point here or on the whole do block - -x' :: IO (K b) -x' = y >> pure () ===================================== testsuite/tests/typecheck/should_fail/T25996.hs deleted ===================================== @@ -1,20 +0,0 @@ - -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Wno-unused-local-binds #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} - -module T25996 where - -main :: IO () -main = do - pure () - where - biz :: IO () - biz = do - pure (10 :: Integer) -- This warning should be reported only once - pure () - -biz' :: IO () -biz' = do - pure (10 :: Integer) - pure () ===================================== testsuite/tests/typecheck/should_fail/T7857.stderr ===================================== @@ -1,8 +1,7 @@ - T7857.hs:8:11: error: [GHC-39999] • Could not deduce ‘PrintfType a0’ arising from a use of ‘printf’ - from the context: PrintfArg t - bound by the inferred type of g :: PrintfArg t => t -> b + from the context: PrintfArg q + bound by the inferred type of g :: PrintfArg q => q -> b at T7857.hs:8:1-21 The type variable ‘a0’ is ambiguous Potentially matching instances: @@ -15,3 +14,4 @@ T7857.hs:8:11: error: [GHC-39999] • In the second argument of ‘($)’, namely ‘printf "" i’ In the expression: f $ printf "" i In an equation for ‘g’: g i = f $ printf "" i + ===================================== testsuite/tests/typecheck/should_fail/tcfail181.stderr ===================================== @@ -1,5 +1,5 @@ tcfail181.hs:17:9: error: [GHC-39999] - • Could not deduce ‘Monad m0’ arising from a record update + • Could not deduce ‘Monad m0’ arising from a use of ‘foo’ from the context: Monad m bound by the inferred type of wog :: Monad m => p -> Something (m Bool) e View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1a3afd5ca3b88ed0472319ef4d667cd2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1a3afd5ca3b88ed0472319ef4d667cd2... You're receiving this email because of your account on gitlab.haskell.org.