[Git][ghc/ghc][wip/T25281] More wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Sep 27 11:10:51 UTC 2024
Simon Peyton Jones pushed to branch wip/T25281 at Glasgow Haskell Compiler / GHC
Commits:
e2c28824 by Simon Peyton Jones at 2024-09-27T12:10:27+01:00
More wibbles
- - - - -
16 changed files:
- compiler/GHC/Core/Type.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- testsuite/tests/linear/should_fail/LinearTHFail2.stderr
- testsuite/tests/linear/should_fail/LinearTHFail3.stderr
Changes:
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -33,7 +33,7 @@ module GHC.Core.Type (
mkScaledFunTys,
mkInvisFunTy, mkInvisFunTys,
tcMkVisFunTy, tcMkScaledFunTys, tcMkInvisFunTy,
- splitFunTy, splitFunTy_maybe,
+ splitFunTy, splitFunTy_maybe, splitVisibleFunTy_maybe,
splitFunTys, funResultTy, funArgTy,
funTyConAppTy_maybe, funTyFlagTyCon,
tyConAppFunTy_maybe, tyConAppFunCo_maybe,
@@ -1443,6 +1443,15 @@ splitFunTy_maybe ty
| FunTy af w arg res <- coreFullView ty = Just (af, w, arg, res)
| otherwise = Nothing
+{-# INLINE splitVisibleFunTy_maybe #-}
+splitVisibleFunTy_maybe :: Type -> Maybe (Type, Type)
+-- ^ Works on visible function types only (t1 -> t2), and
+-- returns t1 and t2, but not the multiplicity
+splitVisibleFunTy_maybe ty
+ | FunTy af _ arg res <- coreFullView ty
+ , isVisibleFunArg af = Just (arg, res)
+ | otherwise = Nothing
+
splitFunTys :: Type -> ([Scaled Type], Type)
splitFunTys ty = split [] ty ty
where
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -146,11 +146,6 @@ noSyntaxExpr = case ghcPass @p of
mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn
mkSyntaxExpr = SyntaxExprRn
--- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the
--- renamer).
-mkRnSyntaxExpr :: Name -> SyntaxExprRn
-mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLocA name
-
instance Outputable SyntaxExprRn where
ppr (SyntaxExprRn expr) = ppr expr
ppr NoSyntaxExprRn = text "<no syntax expr>"
@@ -653,7 +648,7 @@ ppr_lexpr e = ppr_expr (unLoc e)
ppr_expr :: forall p. (OutputableBndrId p)
=> HsExpr (GhcPass p) -> SDoc
-ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v
+ppr_expr (HsVar _ (L loc v)) = pprPrefixOcc v
ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv
ppr_expr (HsRecSel _ f) = pprPrefixOcc f
ppr_expr (HsIPVar _ v) = ppr v
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -53,10 +53,10 @@ module GHC.Hs.Utils(
mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
mkHsCmdIf, mkConLikeTc,
- nlHsTyApp, nlHsTyApps, nlHsVar, nl_HsVar, nlHsDataCon,
+ nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,
nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
nlHsIntLit, nlHsVarApps,
- nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
+ nlHsDo, nlHsOpApp, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
mkLocatedList, nlAscribe,
@@ -504,10 +504,6 @@ nlHsVar :: IsSrcSpanAnn p a
=> IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar n = noLocA (HsVar noExtField (noLocA n))
-nl_HsVar :: IsSrcSpanAnn p a
- => IdP (GhcPass p) -> HsExpr (GhcPass p)
-nl_HsVar n = HsVar noExtField (noLocA n)
-
-- | NB: Only for 'LHsExpr' 'Id'.
nlHsDataCon :: DataCon -> LHsExpr GhcTc
nlHsDataCon con = noLocA (mkConLikeTc (RealDataCon con))
@@ -602,16 +598,11 @@ nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts))
nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2)
-nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
nlHsPar :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
--- AZ:Is this used?
-nlHsLam match = noLocA $ HsLam noAnn LamSingle
- $ mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [match])
-
nlHsPar e = noLocA (gHsPar e)
-- nlHsIf should generate if-expressions which are NOT subject to
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -30,6 +30,7 @@ import GHC.HsToCore.Utils
import GHC.HsToCore.Arrows
import GHC.HsToCore.Monad
import GHC.HsToCore.Pmc
+import GHC.HsToCore.Pmc.Utils
import GHC.HsToCore.Errors.Types
import GHC.HsToCore.Quote
import GHC.HsToCore.Ticks (stripTicksTopHsExpr)
@@ -58,7 +59,6 @@ import GHC.Types.Name hiding (varName)
import GHC.Types.Name.Reader( lookupGRE_FieldLabel )
import GHC.Types.CostCentre
import GHC.Types.Id
-import GHC.Types.Var( isVisibleFunArg )
import GHC.Types.Id.Info
import GHC.Types.Id.Make
import GHC.Types.Basic
@@ -74,6 +74,7 @@ import GHC.Builtin.Names
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
+import Control.Arrow ( first )
import Control.Monad
import Data.Maybe( isJust )
@@ -626,20 +627,20 @@ ds_app (XExpr (ConLikeTc con tvs tys)) _hs_args core_args
ds_app (HsRecSel _ (FieldOcc { foExt = sel_id })) _hs_args core_args
= ds_app_rec_sel sel_id core_args
-ds_app (HsVar _ (L _ fun_id)) hs_args core_args
- = ds_app_var fun_id hs_args core_args
+ds_app (HsVar _ lfun) hs_args core_args
+ = ds_app_var lfun hs_args core_args
ds_app e _hs_args core_args
= do { core_e <- dsExpr e
; return (mkCoreApps core_e core_args) }
---------------
-ds_app_var :: Id -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
+ds_app_var :: LocatedN Id -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
-- Desugar an application with HsVar at the head
-ds_app_var fun_id hs_args core_args
- | fun_id `hasKey` getFieldClassOpKey
- , (_k : Type x_ty : Type r_ty : _a_ty : _dict : rest_args) <- core_args
- -- A getField applications. General form:
+ds_app_var (L loc fun_id) hs_args core_args
+
+ -----------------------
+ -- Deal with getField applications. General form:
-- getField
-- @GHC.Types.Symbol {k}
-- @"sel" x_ty
@@ -651,6 +652,8 @@ ds_app_var fun_id hs_args core_args
-- $dHasField = sel |> (co :: T -> Int ~R# HasField "sel" T Int)
-- Alas, we cannot simply look at the unfolding of $dHasField below because it
-- has not been set yet, so we have to reconstruct the selector Id from the types.
+ | fun_id `hasKey` getFieldClassOpKey
+ , (_k : Type x_ty : Type r_ty : _a_ty : _dict : rest_args) <- core_args
= do { fam_inst_envs <- dsGetFamInstEnvs
; rdr_env <- dsGetGlobalRdrEnv
-- Look up the field named x/"sel" in the type r/T
@@ -662,23 +665,46 @@ ds_app_var fun_id hs_args core_args
; ds_app_rec_sel sel_id rest_args }
_ -> ds_app_done fun_id core_args }
- | fun_id `hasKey` thenMClassOpKey -- it is a (>>)
- , Type arg_ty : _ <- core_args
- , hs_arg : _ <- hs_args
+ -----------------------
+ -- Warn about identities for (fromInteger :: Integer -> Integer) etc
+ -- They all have a type like: forall <tvs>. <cxt> => arg_ty -> res_ty
+ | idName fun_id `elem` numericConversionNames
+ , let (inst_fun_ty, _) = apply_type_args fun_id core_args
+ , (_, conv_ty) <- splitInvisPiTys inst_fun_ty
+ , Just (arg_ty, res_ty) <- splitVisibleFunTy_maybe conv_ty
+ = do { dflags <- getDynFlags
+ ; when (wopt Opt_WarnIdentities dflags
+ && arg_ty `eqType` res_ty) $
+ -- So we are converting ty -> ty
+ diagnosticDs (DsIdentitiesFound fun_id conv_ty)
+
+ ; ds_app_done fun_id core_args }
+
+ -----------------------
-- Warn about unused return value in
-- do { ...; e; ... } when e returns (say) an Int
- = do { loc <- getSrcSpanDs
- ; when (isGeneratedSrcSpan loc) $ -- it is compiler generated (>>)
- warnDiscardedDoBindings hs_arg arg_ty
+ | fun_id `hasKey` thenMClassOpKey -- It is the built-in Prelude.(>>)
+ -- (>>) :: forall m. Monad m => forall a b. m a -> (b->m b) -> m b
+ , Type m_ty : _dict : Type arg_ty : _ <- core_args
+ , hs_arg : _ <- hs_args
+ = do { tracePm ">>" (ppr loc $$ ppr arg_ty $$ ppr (isGeneratedSrcSpan (locA loc)))
+ ; when (isGeneratedSrcSpan (locA loc)) $ -- It is a compiler-generated (>>)
+ warnDiscardedDoBindings hs_arg m_ty arg_ty
; ds_app_done fun_id core_args }
- | fun_id `hasKey` noinlineIdKey -- See Note [noinlineId magic] in GHC.Types.Id.Make
+ -----------------------
+ -- Deal with `noinline`
+ -- See Note [noinlineId magic] in GHC.Types.Id.Make
+ | fun_id `hasKey` noinlineIdKey
, Type _ : arg1 : rest_args <- core_args
, (inner_fun, inner_args) <- collectArgs arg1
= return (Var fun_id `App` Type (exprType inner_fun) `App` inner_fun
`mkCoreApps` inner_args `mkCoreApps` rest_args)
- | fun_id `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2)
+ -----------------------
+ -- Deal with `seq`
+ -- See Note [Desugaring seq], points (1) and (2)
+ | fun_id `hasKey` seqIdKey
, Type _r : Type ty1 : Type ty2 : arg1 : arg2 : rest_args <- core_args
, let case_bndr = case arg1 of
Var v1 | isInternalName (idName v1)
@@ -687,6 +713,8 @@ ds_app_var fun_id hs_args core_args
= return (Case arg1 case_bndr ty2 [Alt DEFAULT [] arg2]
`mkCoreApps` rest_args)
+ -----------------------
+ -- Phew! No more special cases. Just build an applications
| otherwise
= ds_app_done fun_id core_args
@@ -707,7 +735,7 @@ ds_app_rec_sel sel_id core_args
-- data T = T1 | T2 {s :: Bool}
-- g y = map s y -- Warn here
-- f x = s x -- No warning here
- ; let (fun, val_args) = apply_type_args (Var sel_id) core_args
+ ; let (fun_ty, val_args) = apply_type_args sel_id core_args
-- Type-based check.
-- See (3) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
@@ -718,8 +746,7 @@ ds_app_rec_sel sel_id core_args
-- No value argument, but the selector is
-- applied to all its type arguments
- [] | Just (af, _, val_arg_ty, _) <- splitFunTy_maybe (exprType fun)
- , isVisibleFunArg af
+ [] | Just (val_arg_ty, _) <- splitVisibleFunTy_maybe fun_ty
-> do { dummy <- newSysLocalDs (Scaled ManyTy val_arg_ty)
; pmcRecSel sel_id (Var dummy) }
@@ -735,11 +762,23 @@ ds_app_rec_sel sel_id core_args
| otherwise
= pprPanic "ds_app_rec_sel" (ppr sel_id $$ ppr (idDetails sel_id))
where
- -- apply_type_args applies the record selector to its
- -- initial type args, returning the remaining args, if any
- apply_type_args fun (arg : args)
- | isTypeArg arg = apply_type_args (App fun arg) args
- apply_type_args fun args = (fun,args)
+
+-- apply_type_args applies the record selector to its
+-- initial type args, returning the remaining args, if any
+apply_type_args :: Id -> [CoreExpr] -> (Type, [CoreExpr])
+-- Apply function to the initial /type/ args;
+-- return the type of the instantiated function,
+-- and the remaining args
+-- e.g. apply_type_args (++) [Type Int, Var xs]
+-- = ([Int] -> [Int] -> [Int], [Var xs])
+apply_type_args fun args
+ = (piResultTys (idType fun) arg_tys, rest_args)
+ where
+ (arg_tys, rest_args) = go args
+
+ go :: [CoreExpr] -> ([Type], [CoreExpr])
+ go (Type ty : args) = first (ty :) (go args)
+ go args = ([], args)
------------------------------
splitHsWrapperArgs :: HsWrapper -> [CoreArg] -> DsM (HsWrapper, [CoreArg])
@@ -915,7 +954,9 @@ dsDo ctx stmts res_ty
go _ (BodyStmt _ rhs then_expr _) stmts
= do { rhs2 <- dsLExpr rhs
- ; warnDiscardedDoBindings rhs (exprType rhs2)
+ ; case tcSplitAppTy_maybe (exprType rhs2) of
+ Just (m_ty, elt_ty) -> warnDiscardedDoBindings rhs m_ty elt_ty
+ Nothing -> return () -- Odd, but not warning
; rest <- goL stmts
; dsSyntaxExpr then_expr [rhs2, rest] }
@@ -1067,9 +1108,8 @@ Other places that requires from the same treatment:
-}
-- Warn about certain types of values discarded in monadic bindings (#3263)
-warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
-warnDiscardedDoBindings rhs rhs_ty
- | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
+warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> Type -> DsM ()
+warnDiscardedDoBindings rhs m_ty elt_ty
= do { warn_unused <- woptM Opt_WarnUnusedDoBind
; warn_wrong <- woptM Opt_WarnWrongDoBind
; when (warn_unused || warn_wrong) $
@@ -1083,12 +1123,11 @@ warnDiscardedDoBindings rhs rhs_ty
-- Warn about discarding m a things in 'monadic' binding of the same type,
-- but only if we didn't already warn due to Opt_WarnUnusedDoBind
+ -- Example: do { return 3; blah }
+ -- We get (>>) @m d @(m Int) (return 3) blah
when warn_wrong $
- case tcSplitAppTy_maybe norm_elt_ty of
- Just (elt_m_ty, _)
- | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
- -> diagnosticDs (DsWrongDoBind rhs elt_ty)
- _ -> return () } }
-
- | otherwise -- RHS does have type of form (m ty), which is weird
- = return () -- but at least this warning is irrelevant
+ case tcSplitAppTy_maybe norm_elt_ty of
+ Just (elt_m_ty, _)
+ | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
+ -> diagnosticDs (DsWrongDoBind rhs elt_ty)
+ _ -> return () } }
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.HsToCore.Match.Literal
( dsLit, dsOverLit, hsLitKey
, tidyLitPat, tidyNPat
, matchLiterals, matchNPlusKPats, matchNPats
- , warnAboutIdentities
+ , numericConversionNames
, warnAboutOverflowedOverLit, warnAboutOverflowedLit
, warnAboutEmptyEnumerations
)
@@ -275,23 +275,13 @@ between one type and another when the to- and from- types are the
same. Then it's probably (albeit not definitely) the identity
-}
-warnAboutIdentities :: DynFlags -> Id -> Type -> DsM ()
-warnAboutIdentities dflags conv_fn type_of_conv
- | wopt Opt_WarnIdentities dflags
- , idName conv_fn `elem` conversionNames
- , Just (_, _, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
- , arg_ty `eqType` res_ty -- So we are converting ty -> ty
- = diagnosticDs (DsIdentitiesFound conv_fn type_of_conv)
-warnAboutIdentities _ _ _ = return ()
-
-conversionNames :: [Name]
-conversionNames
+numericConversionNames :: [Name]
+numericConversionNames
= [ toIntegerName, toRationalName
, fromIntegralName, realToFracName ]
-- We can't easily add fromIntegerName, fromRationalName,
-- because they are generated by literals
-
-- | Emit warnings on overloaded integral literals which overflow the bounds
-- implied by their type.
warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -51,8 +51,7 @@ module GHC.Rename.Env (
lookupIfThenElse,
-- QualifiedDo
- lookupQualifiedDoExpr, lookupQualifiedDo,
- lookupQualifiedDoName, lookupNameWithQualifier,
+ lookupQualifiedDo, lookupQualifiedDoName, lookupNameWithQualifier,
-- Constructing usage information
DeprecationWarnings(..),
@@ -2350,14 +2349,14 @@ lookupSyntaxExpr :: Name -- ^ The standard name
-> RnM (HsExpr GhcRn, FreeVars) -- ^ Possibly a non-standard name
lookupSyntaxExpr std_name
= do { (name, fvs) <- lookupSyntaxName std_name
- ; return (nl_HsVar name, fvs) }
+ ; return (genHsVar name, fvs) }
lookupSyntax :: Name -- The standard name
-> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard
-- name
lookupSyntax std_name
- = do { (expr, fvs) <- lookupSyntaxExpr std_name
- ; return (mkSyntaxExpr expr, fvs) }
+ = do { (name, fvs) <- lookupSyntaxName std_name
+ ; return (mkRnSyntaxExpr name, fvs) }
lookupSyntaxNames :: [Name] -- Standard names
-> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames
@@ -2387,15 +2386,9 @@ by the Opt_QualifiedDo dynamic flag.
-- Lookup operations for a qualified do. If the context is not a qualified
-- do, then use lookupSyntaxExpr. See Note [QualifiedDo].
-lookupQualifiedDoExpr :: HsStmtContext fn -> Name -> RnM (HsExpr GhcRn, FreeVars)
-lookupQualifiedDoExpr ctxt std_name
- = first nl_HsVar <$> lookupQualifiedDoName ctxt std_name
-
--- Like lookupQualifiedDoExpr but for producing SyntaxExpr.
--- See Note [QualifiedDo].
lookupQualifiedDo :: HsStmtContext fn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDo ctxt std_name
- = first mkSyntaxExpr <$> lookupQualifiedDoExpr ctxt std_name
+ = first mkRnSyntaxExpr <$> lookupQualifiedDoName ctxt std_name
lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars)
lookupNameWithQualifier std_name modName
@@ -2406,7 +2399,7 @@ lookupNameWithQualifier std_name modName
lookupQualifiedDoName :: HsStmtContext fn -> Name -> RnM (Name, FreeVars)
lookupQualifiedDoName ctxt std_name
= case qualifiedDoModuleName_maybe ctxt of
- Nothing -> lookupSyntaxName std_name
+ Nothing -> lookupSyntaxName std_name
Just modName -> lookupNameWithQualifier std_name modName
--------------------------------------------------------------------------------
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -30,32 +30,27 @@ module GHC.Rename.Expr (
) where
import GHC.Prelude
-import GHC.Data.FastString
-
-import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS
- , rnMatchGroup, rnGRHS, makeMiniFixityEnv)
import GHC.Hs
+
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Env ( isBrackStage )
import GHC.Tc.Utils.Monad
-import GHC.Unit.Module ( getModule, isInteractiveModule )
+
+import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS
+ , rnMatchGroup, rnGRHS, makeMiniFixityEnv)
import GHC.Rename.Env
import GHC.Rename.Fixity
-import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames
- , bindLocalNames
- , mapMaybeFvRn, mapFvRn
- , warnUnusedLocalBinds, typeAppErr
- , checkUnusedRecordWildcard
- , wrapGenSpan, genHsIntegralLit, genHsTyLit
- , genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps'
- , genAppType )
+import GHC.Rename.Utils
import GHC.Rename.Unbound ( reportUnboundName )
-import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnTypedSplice, rnUntypedSpliceExpr, checkThLocalName )
+import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnTypedSplice
+ , rnUntypedSpliceExpr, checkThLocalName )
import GHC.Rename.HsType
import GHC.Rename.Pat
+
import GHC.Driver.DynFlags
import GHC.Builtin.Names
import GHC.Builtin.Types ( nilDataConName )
+import GHC.Unit.Module ( getModule, isInteractiveModule )
import GHC.Types.Basic (TypeOrKind (TypeLevel))
import GHC.Types.FieldLabel
@@ -67,13 +62,16 @@ import GHC.Types.Name.Reader
import GHC.Types.Unique.Set
import GHC.Types.SourceText
import GHC.Types.SrcLoc
+
import GHC.Utils.Misc
-import GHC.Data.List.SetOps ( removeDupsOn )
-import GHC.Data.Maybe
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
+import GHC.Data.FastString
+import GHC.Data.List.SetOps ( removeDupsOn )
+import GHC.Data.Maybe
+
import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
@@ -1415,7 +1413,7 @@ lookupQualifiedDoStmtName ctxt n
= case qualifiedDoModuleName_maybe ctxt of
Nothing -> lookupStmtName ctxt n
Just modName ->
- first (mkSyntaxExpr . nl_HsVar) <$> lookupNameWithQualifier n modName
+ first mkRnSyntaxExpr <$> lookupNameWithQualifier n modName
lookupStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
-- Like lookupSyntax, but respects contexts
@@ -2032,10 +2030,9 @@ rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
rearrangeForApplicativeDo ctxt [(one,_)] = do
(return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName
(pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
- let pure_expr = nl_HsVar pure_name
let monad_names = MonadNames { return_name = return_name
, pure_name = pure_name }
- return $ case needJoin monad_names [one] (Just pure_expr) of
+ return $ case needJoin monad_names [one] (Just pure_name) of
(False, one') -> (one', emptyNameSet)
(True, _) -> ([one], emptyNameSet)
rearrangeForApplicativeDo ctxt stmts0 = do
@@ -2197,8 +2194,8 @@ stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
}] False tail'
stmtTreeToStmts monad_names ctxt (StmtTreeOne (let_stmt@(L _ LetStmt{}),_))
tail _tail_fvs = do
- (pure_expr, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName
- return $ case needJoin monad_names tail (Just pure_expr) of
+ (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
+ return $ case needJoin monad_names tail (Just pure_name) of
(False, tail') -> (let_stmt : tail', emptyNameSet)
(True, _) -> (let_stmt : tail, emptyNameSet)
@@ -2256,8 +2253,8 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
| otherwise -> do
-- Need 'pureAName' and not 'returnMName' here, so that it requires
-- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed).
- (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName
- let expr = HsApp noExtField (noLocA ret) tup
+ (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
+ let expr = HsApp noExtField (noLocA (genHsVar pure_name)) tup
return (expr, emptyFVs)
return ( ApplicativeArgMany
{ xarg_app_arg_many = noExtField
@@ -2523,7 +2520,7 @@ needJoin :: MonadNames
-> [ExprLStmt GhcRn]
-- If this is @Just pure@, replace return by pure
-- If this is @Nothing@, strip the return/pure
- -> Maybe (HsExpr GhcRn)
+ -> Maybe Name
-> (Bool, [ExprLStmt GhcRn])
needJoin _monad_names [] _mb_pure = (False, []) -- we're in an ApplicativeArg
needJoin monad_names [L loc (LastStmt _ e _ t)] mb_pure
@@ -2544,18 +2541,18 @@ isReturnApp :: MonadNames
-> LHsExpr GhcRn
-- If this is @Just pure@, replace return by pure
-- If this is @Nothing@, strip the return/pure
- -> Maybe (HsExpr GhcRn)
+ -> Maybe Name
-> Maybe (LHsExpr GhcRn, Maybe Bool)
isReturnApp monad_names (L _ (HsPar _ expr)) mb_pure =
isReturnApp monad_names expr mb_pure
isReturnApp monad_names (L loc e) mb_pure = case e of
OpApp x l op r
- | Just pure_expr <- mb_pure, is_return l, is_dollar op ->
- Just (L loc (OpApp x (to_pure l pure_expr) op r), Nothing)
+ | Just pure_name <- mb_pure, is_return l, is_dollar op ->
+ Just (L loc (OpApp x (to_pure l pure_name) op r), Nothing)
| is_return l, is_dollar op -> Just (r, Just True)
HsApp x f arg
- | Just pure_expr <- mb_pure, is_return f ->
- Just (L loc (HsApp x (to_pure f pure_expr) arg), Nothing)
+ | Just pure_name <- mb_pure, is_return f ->
+ Just (L loc (HsApp x (to_pure f pure_name) arg), Nothing)
| is_return f -> Just (arg, Just False)
_otherwise -> Nothing
where
@@ -2567,7 +2564,7 @@ isReturnApp monad_names (L loc e) mb_pure = case e of
is_return = is_var (\n -> n == return_name monad_names
|| n == pure_name monad_names)
- to_pure (L loc _) pure_expr = L loc pure_expr
+ to_pure (L loc _) pure_name = L loc (genHsVar pure_name)
is_dollar = is_var (`hasKey` dollarIdKey)
{-
@@ -2793,13 +2790,13 @@ getMonadFailOp ctxt
reallyGetMonadFailOp rebindableSyntax overloadedStrings
| (isQualifiedDo || rebindableSyntax) && overloadedStrings = do
- (failExpr, failFvs) <- lookupQualifiedDoExpr ctxt failMName
+ (failName, failFvs) <- lookupQualifiedDoName ctxt failMName
(fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName
let arg_lit = mkVarOccFS (fsLit "arg")
arg_name <- newSysName arg_lit
let arg_syn_expr = nlHsVar arg_name
body :: LHsExpr GhcRn =
- nlHsApp (noLocA failExpr)
+ nlHsApp (noLocA (genHsVar failName))
(nlHsApp (noLocA $ fromStringExpr) arg_syn_expr)
let failAfterFromStringExpr :: HsExpr GhcRn =
unLoc $ mkHsLam (noLocA [noLocA $ VarPat noExtField $ noLocA arg_name]) body
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -1176,9 +1176,9 @@ rnOverLit origLit
lit' = lit { ol_ext = OverLitRn { ol_rebindable = rebindable
, ol_from_fun = L (noAnnSrcSpan loc) from_thing_name } }
; if isNegativeZeroOverLit lit'
- then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName
- ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
- , fvs1 `plusFV` fvs2) }
+ then do { (negate_expr, fvs2) <- lookupSyntaxExpr negateName
+ ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_expr)
+ , fvs1 `plusFV` fvs2) }
else return ((lit', Nothing), fvs1) }
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -25,10 +25,9 @@ module GHC.Rename.Utils (
genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat,
genVarPat, genWildPat,
genSimpleFunBind, genFunBind,
+ genHsLamDoExp, genHsCaseAltDoExp, genSimpleMatch, genHsLet,
- genHsLamDoExp, genHsCaseAltDoExp, genSimpleMatch,
-
- genHsLet,
+ mkRnSyntaxExpr,
newLocalBndrRn, newLocalBndrsRn,
@@ -713,6 +712,14 @@ wrapGenSpan :: (HasAnnotation an) => a -> GenLocated an a
-- See Note [Rebindable syntax and XXExprGhcRn]
wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
+-- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the
+-- renamer).
+mkRnSyntaxExpr :: Name -> SyntaxExprRn
+mkRnSyntaxExpr = SyntaxExprRn . genHsVar
+
+genHsVar :: Name -> HsExpr GhcRn
+genHsVar n = HsVar noExtField (wrapGenSpan n)
+
genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps fun args = foldl genHsApp (genHsVar fun) args
@@ -733,9 +740,6 @@ genLHsApp fun arg = wrapGenSpan (genHsApp fun arg)
genLHsVar :: Name -> LHsExpr GhcRn
genLHsVar nm = wrapGenSpan $ genHsVar nm
-genHsVar :: Name -> HsExpr GhcRn
-genHsVar nm = HsVar noExtField $ wrapGenSpan nm
-
genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) (mkEmptyWildCardBndrs (wrapGenSpan ty))
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -23,7 +23,8 @@ import GHC.Prelude
import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,
genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
-import GHC.Rename.Env ( irrefutableConLikeRn )
+import GHC.Rename.Env ( irrefutableConLikeRn )
+
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcMType
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -568,7 +568,7 @@ tcExpr expr@(RecordCon { rcon_con = L loc con_name
, rcon_flds = rbinds }) res_ty
= do { con_like <- tcLookupConLike con_name
- ; (con_expr, con_sigma) <- tcInferId con_name
+ ; (con_expr, con_sigma) <- tcInferConLike con_like
; (con_wrap, con_tau) <- topInstantiate orig con_sigma
-- a shallow instantiation should really be enough for
-- a data constructor.
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -23,7 +23,7 @@ module GHC.Tc.Gen.Head
, leadingValArgs, isVisibleArg
, tcInferAppHead, tcInferAppHead_maybe
- , tcInferId, tcCheckId, obviousSig
+ , tcInferId, tcCheckId, tcInferConLike, obviousSig
, tyConOf, tyConOfET, fieldNotInType
, nonBidirectionalErr
@@ -58,7 +58,7 @@ import GHC.Tc.Zonk.TcType
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Core.UsageEnv ( singleUsageUE )
-import GHC.Core.PatSyn( PatSyn )
+import GHC.Core.PatSyn( PatSyn, patSynName )
import GHC.Core.ConLike( ConLike(..) )
import GHC.Core.DataCon
import GHC.Core.TyCon
@@ -566,7 +566,7 @@ tcInferAppHead_maybe :: HsExpr GhcRn
-- Returns Nothing for a complicated head
tcInferAppHead_maybe fun
= case fun of
- HsVar _ (L _ nm) -> Just <$> tcInferId nm
+ HsVar _ nm -> Just <$> tcInferId nm
HsRecSel _ f -> Just <$> tcInferRecSelId f
ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty
HsOverLit _ lit -> Just <$> tcInferOverLit lit
@@ -793,7 +793,7 @@ tcInferOverLit lit@(OverLit { ol_val = val
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId name res_ty
- = do { (expr, actual_res_ty) <- tcInferId name
+ = do { (expr, actual_res_ty) <- tcInferId (noLocA name)
; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
; addFunResCtxt expr [] actual_res_ty res_ty $
tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty }
@@ -801,33 +801,33 @@ tcCheckId name res_ty
rn_fun = HsVar noExtField (noLocA name)
------------------------
-tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
+tcInferId :: LocatedN Name -> TcM (HsExpr GhcTc, TcSigmaType)
-- Look up an occurrence of an Id
-- Do not instantiate its type
-tcInferId id_name
+tcInferId lname@(L _ id_name)
| id_name `hasKey` assertIdKey
= do { dflags <- getDynFlags
; if gopt Opt_IgnoreAsserts dflags
- then tc_infer_id id_name
- else tc_infer_assert id_name }
+ then tc_infer_id lname
+ else tc_infer_assert lname }
| otherwise
- = do { (expr, ty) <- tc_infer_id id_name
+ = do { (expr, ty) <- tc_infer_id lname
; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
; return (expr, ty) }
-tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
+tc_infer_assert :: LocatedN Name -> TcM (HsExpr GhcTc, TcSigmaType)
-- Deal with an occurrence of 'assert'
-- See Note [Adding the implicit parameter to 'assert']
-tc_infer_assert assert_name
+tc_infer_assert (L loc assert_name)
= do { assert_error_id <- tcLookupId assertErrorName
; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
(idType assert_error_id)
- ; return (mkHsWrap wrap (HsVar noExtField (noLocA assert_error_id)), id_rho)
+ ; return (mkHsWrap wrap (HsVar noExtField (L loc assert_error_id)), id_rho)
}
-tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
-tc_infer_id id_name
+tc_infer_id :: LocatedN Name -> TcM (HsExpr GhcTc, TcSigmaType)
+tc_infer_id (L loc id_name)
= do { thing <- tcLookup id_name
; case thing of
ATcId { tct_id = id }
@@ -839,14 +839,14 @@ tc_infer_id id_name
-- nor does it need the 'lifting' treatment
-- Hence no checkTh stuff here
- AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con
- AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps
+ AGlobal (AConLike cl) -> tcInferConLike cl
+
(tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything (tyConName tc)
ATyVar name _ -> failIllegalTyVal name
_ -> failWithTc $ TcRnExpectedValueId thing }
where
- return_id id = return (HsVar noExtField (noLocA id), idType id)
+ return_id id = return (HsVar noExtField (L loc id), idType id)
{- Note [Suppress hints with RequiredTypeArguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -903,6 +903,10 @@ check_naughty lbl id
| isNaughtyRecordSelector id = failWithTc (TcRnRecSelectorEscapedTyVar lbl)
| otherwise = return ()
+tcInferConLike :: ConLike -> TcM (HsExpr GhcTc, TcSigmaType)
+tcInferConLike (RealDataCon con) = tcInferDataCon con
+tcInferConLike (PatSynCon ps) = tcInferPatSyn ps
+
tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
-- See Note [Typechecking data constructors]
tcInferDataCon con
@@ -934,11 +938,11 @@ tcInferDataCon con
; return (Scaled mul_var ty) }
linear_to_poly scaled_ty = return scaled_ty
-tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
-tcInferPatSyn id_name ps
+tcInferPatSyn :: PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
+tcInferPatSyn ps
= case patSynBuilderOcc ps of
Just (expr,ty) -> return (expr,ty)
- Nothing -> failWithTc (nonBidirectionalErr id_name)
+ Nothing -> failWithTc (nonBidirectionalErr (patSynName ps))
nonBidirectionalErr :: Name -> TcRnMessage
nonBidirectionalErr = TcRnPatSynNotBidirectional
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -91,7 +91,7 @@ import GHC.Rename.Names
import GHC.Rename.Env
import GHC.Rename.Module
import GHC.Rename.Doc
-import GHC.Rename.Utils ( mkNameClashErr )
+import GHC.Rename.Utils ( mkNameClashErr, mkRnSyntaxExpr )
import GHC.Iface.Decl ( coAxiomToIfaceDecl )
import GHC.Iface.Env ( externaliseName )
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -71,6 +71,8 @@ import GHC.Tc.Utils.TcType
import GHC.Tc.Errors.Types
import GHC.Tc.Zonk.Monad ( ZonkM )
+import GHC.Rename.Utils( mkRnSyntaxExpr )
+
import GHC.Types.Id.Make( mkDictFunId )
import GHC.Types.Basic ( TypeOrKind(..), Arity, VisArity )
import GHC.Types.Error
=====================================
testsuite/tests/linear/should_fail/LinearTHFail2.stderr
=====================================
@@ -1,3 +1,3 @@
-LinearTHFail2.hs:7:2: error: [GHC-65904]
+LinearTHFail2.hs:7:3: error: [GHC-65904]
Non-linear fields in data constructors not (yet) handled by Template Haskell
=====================================
testsuite/tests/linear/should_fail/LinearTHFail3.stderr
=====================================
@@ -1,3 +1,3 @@
-LinearTHFail3.hs:7:2: error: [GHC-65904]
+LinearTHFail3.hs:7:3: error: [GHC-65904]
Non-linear fields in data constructors not (yet) handled by Template Haskell
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2c288248a4be2a427b08659248742f79eb41612
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2c288248a4be2a427b08659248742f79eb41612
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240927/fefc414a/attachment-0001.html>
More information about the ghc-commits
mailing list