[Git][ghc/ghc][wip/improve-implicit-lifting-error] Improve error messages when implicit lifting fails
Matthew Pickering pushed to branch wip/improve-implicit-lifting-error at Glasgow Haskell Compiler / GHC
Commits:
fe034312 by Matthew Pickering at 2025-05-13T16:17:34+01:00
Improve error messages when implicit lifting fails
This patch concerns programs which automatically try to fix level errors
by inserting `Lift`. For example:
```
foo x = [| x |]
~>
foo x = [| $(lift x) |]
```
Before, there were two problems with the message.
1. (#26031), the location of the error was reported as the whole
quotation.
2. (#26035), the message just mentions there is no Lift instance, but
gives no indicate why the user program needed a Lift instance in the
first place.
This problem is especially bad when you disable
`ImplicitStagePersistence`, so you just end up with a confusing "No
instance for" message rather than an error message about levels
This patch fixes both these issues.
Firstly, `PendingRnSplice` differentiates between a user-written splice
and an implicit lift. Then, the Lift instance is precisely requested
with a specific origin in the typechecker. If the instance fails to be
solved, the message is reported using the `TcRnBadlyLevelled`
constructor (like a normal level error).
Fixes #26031, #26035
- - - - -
17 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Types/ThLevelIndex.hs
- + testsuite/tests/quotes/LiftErrMsg.hs
- + testsuite/tests/quotes/LiftErrMsg.stderr
- + testsuite/tests/quotes/LiftErrMsgDefer.hs
- + testsuite/tests/quotes/LiftErrMsgDefer.stderr
- testsuite/tests/quotes/all.T
- testsuite/tests/th/TH_Lift.stderr
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -55,6 +55,7 @@ import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Types.Tickish (CoreTickish)
import GHC.Types.Unique.Set (UniqSet)
+import GHC.Types.ThLevelIndex
import GHC.Core.ConLike ( conLikeName, ConLike )
import GHC.Unit.Module (ModuleName)
import GHC.Utils.Misc
@@ -78,7 +79,7 @@ import Data.Foldable ( toList )
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Void (Void)
-
+import qualified Data.Set as S
{- *********************************************************************
* *
Expressions proper
@@ -2252,8 +2253,12 @@ data UntypedSpliceFlavour
deriving Data
-- | Pending Renamer Splice
+-- There are two types of pending splices:
+-- 1. A splice explicitly written by the user, e.g. `[| $(foo) |]`
+-- 2. A cross-stage reference which we will attempt to fix by using Lift.
data PendingRnSplice
= PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)
+ | PendingImplicitLift (S.Set ThLevelIndex) ThLevelIndex (Maybe GlobalRdrElt) (LIdOccP GhcRn)
-- | Pending Type-checker Splice
data PendingTcSplice
@@ -2346,6 +2351,7 @@ thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]"
instance Outputable PendingRnSplice where
ppr (PendingRnSplice _ n e) = pprPendingSplice n e
+ ppr (PendingImplicitLift _bound _used _gre n) = text "implicit lift:" <+> ppr n
instance Outputable PendingTcSplice where
ppr (PendingTcSplice n e) = pprPendingSplice n e
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -2027,6 +2027,7 @@ instance ToHie (HsQuote GhcRn) where
instance ToHie PendingRnSplice where
toHie (PendingRnSplice _ _ e) = toHie e
+ toHie (PendingImplicitLift _bound _used _gre l) = toHie @(LHsExpr GhcRn) (L (l2l (getLoc l)) (HsVar noExtField l))
instance ToHie PendingTcSplice where
toHie (PendingTcSplice _ e) = toHie e
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -328,7 +328,7 @@ rnExpr (HsVar _ (L l v))
-- matching GRE and add a name clash error
-- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn).
-> do { let sel_name = flSelector $ recFieldLabel fld_info
- ; unless (isExact v || isOrig v) $ checkThLocalNameWithLift sel_name
+ ; unless (isExact v || isOrig v) $ checkThLocalNameWithLift (L (l2l l) (WithUserRdr v sel_name))
; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFV sel_name)
}
| nm == nilDataConName
@@ -339,8 +339,9 @@ rnExpr (HsVar _ (L l v))
-> rnExpr (ExplicitList noAnn [])
| otherwise
- -> do { unless (isExact v || isOrig v) (checkThLocalNameWithLift nm)
- ; return (HsVar noExtField (L (l2l l) (WithUserRdr v nm)), unitFV nm) }
+ -> do { let res_name = L (l2l l) (WithUserRdr v nm)
+ ; unless (isExact v || isOrig v) (checkThLocalNameWithLift res_name)
+ ; return (HsVar noExtField res_name, unitFV nm) }
}}}
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -51,7 +51,7 @@ import GHC.Data.FastString
import GHC.Utils.Logger
import GHC.Utils.Panic
import GHC.Driver.Hooks
-import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName
+import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName
, patQTyConName, quoteDecName, quoteExpName
, quotePatName, quoteTypeName, typeQTyConName)
@@ -184,7 +184,8 @@ rnUntypedBracket e br_body
rn_utbracket :: HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)
rn_utbracket (VarBr _ flg rdr_name)
= do { name <- lookupOccRn (if flg then WL_Term else WL_Type) (unLoc rdr_name)
- ; if flg then checkThLocalNameNoLift name else checkThLocalTyName name
+ ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) name)
+ ; if flg then checkThLocalNameNoLift res_name else checkThLocalTyName name
; check_namespace flg name
; return (VarBr noExtField flg (noLocA name), unitFV name) }
@@ -423,9 +424,10 @@ rnUntypedSplice (HsUntypedSpliceExpr annCo expr)
rnUntypedSplice (HsQuasiQuote ext quoter quote)
= do { -- Rename the quoter; akin to the HsVar case of rnExpr
; quoter' <- lookupOccRn WL_TermVariable quoter
+ ; let res_name = noLocA (WithUserRdr quoter quoter')
; this_mod <- getModule
; when (nameIsLocalOrFrom this_mod quoter') $
- checkThLocalNameNoLift quoter'
+ checkThLocalNameNoLift res_name
; return (HsQuasiQuote ext quoter' quote, unitFV quoter') }
@@ -932,17 +934,17 @@ checkThLocalTyName name
-- | Check whether we are allowed to use a Name in this context (for TH purposes)
-- In the case of a level incorrect program, attempt to fix it by using
-- a Lift constraint.
-checkThLocalNameWithLift :: Name -> RnM ()
+checkThLocalNameWithLift :: LIdOccP GhcRn -> RnM ()
checkThLocalNameWithLift = checkThLocalName True
-- | Check whether we are allowed to use a Name in this context (for TH purposes)
-- In the case of a level incorrect program, do not attempt to fix it by using
-- a Lift constraint.
-checkThLocalNameNoLift :: Name -> RnM ()
+checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM ()
checkThLocalNameNoLift = checkThLocalName False
-checkThLocalName :: Bool -> Name -> RnM ()
-checkThLocalName allow_lifting name
+checkThLocalName :: Bool -> LIdOccP GhcRn -> RnM ()
+checkThLocalName allow_lifting name_var
| isUnboundName name -- Do not report two errors for
= return () -- $(not_in_scope args)
@@ -964,7 +966,9 @@ checkThLocalName allow_lifting name
; dflags <- getDynFlags
; env <- getGlobalRdrEnv
; let mgre = lookupGRE_Name env name
- ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name } } }
+ ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var } } }
+ where
+ name = getName name_var
--------------------------------------
checkCrossLevelLifting :: DynFlags
@@ -975,8 +979,8 @@ checkCrossLevelLifting :: DynFlags
-> Set.Set ThLevelIndex
-> ThLevel
-> ThLevelIndex
- -> Name -> TcM ()
-checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name
+ -> LIdOccP GhcRn -> TcM ()
+checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var
-- 1. If name is in-scope, at the correct level.
| use_lvl_idx `Set.member` bind_lvl = return ()
-- 2. Name is imported with -XImplicitStagePersistence
@@ -993,52 +997,26 @@ checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use
, any (use_lvl_idx >=) (Set.toList bind_lvl)
, allow_lifting
= do
- dflags <- getDynFlags
- check_cross_level_lifting dflags top_lvl name ps_var
+ let mgre = case reason of
+ LevelCheckSplice _ gre -> gre
+ _ -> Nothing
+ let pend_splice = PendingImplicitLift bind_lvl use_lvl_idx mgre name_var
+ -- Warning for implicit lift (#17804)
+ addDetailedDiagnostic (TcRnImplicitLift name)
+
+ -- Update the pending splices
+ ps <- readMutVar ps_var
+ writeMutVar ps_var (pend_splice : ps)
-- 5. For a typed bracket, these checks happen again later on (checkThLocalId)
-- In the future we should do all the level checks here.
| Brack _ RnPendingTyped <- use_lvl -- Lift for typed brackets is inserted later.
, any (use_lvl_idx >=) (Set.toList bind_lvl)
= return ()
-- Otherwise, we have a level error, report.
- | otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx)
-
-check_cross_level_lifting :: DynFlags -> TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
-check_cross_level_lifting dflags top_lvl name ps_var
- | isTopLevel top_lvl
- , xopt LangExt.ImplicitStagePersistence dflags
- -- Top-level identifiers in this module,
- -- (which have External Names)
- -- are just like the imported case:
- -- no need for the 'lifting' treatment
- -- E.g. this is fine:
- -- f x = x
- -- g y = [| f 3 |]
- = when (isExternalName name) (keepAlive name)
- -- See Note [Keeping things alive for Template Haskell]
+ | otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx Nothing ErrorWithoutFlag)
+ where
+ name = getName name_var
- | otherwise
- = -- Nested identifiers, such as 'x' in
- -- E.g. \x -> [| h x |]
- -- We must behave as if the reference to x was
- -- h $(lift x)
- -- We use 'x' itself as the SplicePointName, used by
- -- the desugarer to stitch it all back together.
- -- If 'x' occurs many times we may get many identical
- -- bindings of the same SplicePointName, but that doesn't
- -- matter, although it's a mite untidy.
- do { traceRn "checkCrossLevelLifting" (ppr name)
-
- -- Construct the (lift x) expression
- ; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name)
- pend_splice = PendingRnSplice UntypedExpSplice name lift_expr
-
- -- Warning for implicit lift (#17804)
- ; addDetailedDiagnostic (TcRnImplicitLift name)
-
- -- Update the pending splices
- ; ps <- readMutVar ps_var
- ; writeMutVar ps_var (pend_splice : ps) }
checkCrossLevelLiftingTy :: DynFlags -> TopLevelFlag -> Set.Set ThLevelIndex -> ThLevel -> ThLevelIndex -> Name -> TcM ()
checkCrossLevelLiftingTy dflags top_lvl bind_lvl _use_lvl use_lvl_idx name
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -610,6 +610,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter)
-- (Handles TypeError and Unsatisfiable)
+ , ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter)
, given_eq_spec
, ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr)
, ("skolem eq1", very_wrong, True, mkSkolReporter)
@@ -671,6 +672,11 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
-- See also Note [Implementation of Unsatisfiable constraints], point (F).
is_user_type_error item _ = containsUserTypeError (errorItemPred item)
+ is_implicit_lifting item _ =
+ case (errorItemOrigin item) of
+ ImplicitLiftOrigin {} -> True
+ _ -> False
+
is_homo_equality _ (EqPred _ ty1 ty2)
= typeKind ty1 `tcEqType` typeKind ty2
is_homo_equality _ _
@@ -1082,7 +1088,7 @@ mkUserTypeErrorReporter :: Reporter
mkUserTypeErrorReporter ctxt
= mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item
; maybeReportError ctxt (item :| []) err
- ; addDeferredBinding err item }
+ ; addSolverDeferredBinding err item }
mkUserTypeError :: ErrorItem -> TcSolverReportMsg
mkUserTypeError item
@@ -1095,6 +1101,21 @@ mkUserTypeError item
where
pty = errorItemPred item
+mkImplicitLiftingReporter :: Reporter
+mkImplicitLiftingReporter ctxt
+ = mapM_ $ \item -> do { let err = mkImplicitLiftingError item
+ ; msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item)) err (Just ctxt) [] []
+ ; reportDiagnostic msg
+ ; addDeferredBinding ctxt [] [] err item
+ }
+
+ where
+ mkImplicitLiftingError :: ErrorItem -> TcRnMessage
+ mkImplicitLiftingError item =
+ case errorItemOrigin item of
+ ImplicitLiftOrigin bound used gre name -> TcRnBadlyLevelled (LevelCheckSplice name gre) bound used (Just item) (cec_defer_type_errors ctxt)
+ _ -> pprPanic "mkImplicitLiftingError" (ppr item)
+
mkGivenErrorReporter :: Reporter
-- See Note [Given errors]
mkGivenErrorReporter ctxt (item:|_)
@@ -1192,7 +1213,7 @@ reportGroup mk_err ctxt items
; maybeReportError ctxt items err
-- But see Note [Always warn with -fdefer-type-errors]
; traceTc "reportGroup" (ppr items)
- ; mapM_ (addDeferredBinding err) items }
+ ; mapM_ (addSolverDeferredBinding err) items }
-- Add deferred bindings for all
-- Redundant if we are going to abort compilation,
-- but that's hard to know for sure, and if we don't
@@ -1225,15 +1246,23 @@ maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = import
msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp hints
reportDiagnostic msg
-addDeferredBinding :: SolverReport -> ErrorItem -> TcM ()
+addSolverDeferredBinding :: SolverReport -> ErrorItem -> TcM ()
+addSolverDeferredBinding err item =
+ let ctxt = reportContext . sr_important_msg $ err
+ supp = sr_supplementary err
+ hints = sr_hints err
+ important = sr_important_msg err
+ in addDeferredBinding ctxt supp hints (TcRnSolverReport important ErrorWithoutFlag) item
+
+
+addDeferredBinding :: SolverReportErrCtxt -> [SupplementaryInfo] -> [GhcHint] -> TcRnMessage -> ErrorItem -> TcM ()
-- See Note [Deferring coercion errors to runtime]
-addDeferredBinding err (EI { ei_evdest = Just dest
- , ei_pred = item_ty
- , ei_loc = loc })
+addDeferredBinding ctxt supp hints msg (EI { ei_evdest = Just dest
+ , ei_pred = item_ty
+ , ei_loc = loc })
-- if evdest is Just, then the constraint was from a wanted
- | let ctxt = reportContext . sr_important_msg $ err
- , deferringAnyBindings ctxt
- = do { err_tm <- mkErrorTerm loc item_ty err
+ | deferringAnyBindings ctxt
+ = do { err_tm <- mkErrorTerm loc item_ty ctxt msg supp hints
; let ev_binds_var = cec_binds ctxt
; case dest of
@@ -1244,15 +1273,24 @@ addDeferredBinding err (EI { ei_evdest = Just dest
let co_var = coHoleCoVar hole
; addTcEvBind ev_binds_var $ mkWantedEvBind co_var EvNonCanonical err_tm
; fillCoercionHole hole (mkCoVarCo co_var) } }
-addDeferredBinding _ _ = return () -- Do not set any evidence for Given
+addDeferredBinding _ _ _ _ _ = return () -- Do not set any evidence for Given
+
+mkSolverErrorTerm :: CtLoc -> Type -- of the error term
+ -> SolverReport -> TcM EvTerm
+mkSolverErrorTerm ct_loc ty err
+ = mkErrorTerm ct_loc ty (reportContext . sr_important_msg $ err)
+ (TcRnSolverReport (sr_important_msg err) ErrorWithoutFlag)
+ (sr_supplementary err)
+ (sr_hints err)
mkErrorTerm :: CtLoc -> Type -- of the error term
- -> SolverReport -> TcM EvTerm
-mkErrorTerm ct_loc ty (SolverReport { sr_important_msg = important, sr_supplementary = supp, sr_hints = hints })
+ -> SolverReportErrCtxt -> TcRnMessage
+ -> [SupplementaryInfo] -> [GhcHint] -> TcM EvTerm
+mkErrorTerm ct_loc ty ctxt msg supp hints
= do { msg <- mkErrorReport
(ctLocEnv ct_loc)
- (TcRnSolverReport important ErrorWithoutFlag)
- (Just $ reportContext important)
+ msg
+ (Just $ ctxt)
supp
hints
-- This will be reported at runtime, so we always want "error:" in the report, never "warning:"
@@ -1526,7 +1564,7 @@ maybeAddDeferredBindings hole report = do
-- not for holes in partial type signatures
-- cf. addDeferredBinding
when (deferringAnyBindings ctxt) $ do
- err_tm <- mkErrorTerm (hole_loc hole) ref_ty report
+ err_tm <- mkSolverErrorTerm (hole_loc hole) ref_ty report
-- NB: ref_ty, not hole_ty. hole_ty might be rewritten.
-- See Note [Holes in expressions] in GHC.Hs.Expr
writeMutVar ref err_tm
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -105,6 +105,7 @@ import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Fixity (defaultFixity)
+import GHC.Types.ThLevelIndex (pprThBindLevel)
import GHC.Iface.Errors.Types
import GHC.Iface.Errors.Ppr
@@ -1517,23 +1518,8 @@ instance Diagnostic TcRnMessage where
hsep [ text "Unknown type variable" <> plural errorVars
, text "on the RHS of injectivity condition:"
, interpp'SP errorVars ]
- TcRnBadlyLevelled reason bind_lvls use_lvl
- ->
- mkSimpleDecorated $
- vcat $
- [ fsep [ text "Level error:", pprLevelCheckReason reason
- , text "is bound at" <+> pprThBindLevel bind_lvls
- , text "but used at level" <+> ppr use_lvl]
- ] ++
- [ fsep [ text "Hint: quoting" <+> thBrackets (ppUnless (isValName n) "t") (ppr n)
- , text "or an enclosing expression"
- , text "would allow the quotation to be used at an earlier level"
- ]
- | LevelCheckSplice n _ <- [reason]
- ] ++
- [ "From imports" <+> (ppr (gre_imp gre))
- | LevelCheckSplice _ (Just gre) <- [reason]
- , not (isEmptyBag (gre_imp gre)) ]
+ TcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt _reason
+ -> pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt
TcRnBadlyLevelledType name bind_lvls use_lvl
-> mkSimpleDecorated $
text "Badly levelled type:" <+> ppr name <+>
@@ -2490,8 +2476,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnUnknownTyVarsOnRhsOfInjCond{}
-> ErrorWithoutFlag
- TcRnBadlyLevelled{}
- -> ErrorWithoutFlag
+ TcRnBadlyLevelled _ _ _ _ reason
+ -> reason
TcRnBadlyLevelledType{}
-> WarningWithFlag Opt_WarnBadlyLevelledTypes
TcRnTyThingUsedWrong{}
@@ -3389,6 +3375,22 @@ instance Diagnostic TcRnMessage where
diagnosticCode = constructorCode @GHC
+pprTcRnBadlyLevelled :: LevelCheckReason -> Set.Set ThLevelIndex -> ThLevelIndex -> Maybe ErrorItem -> DecoratedSDoc
+pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt = mkDecorated $
+ [ fsep [ text "Level error:", pprLevelCheckReason reason
+ , text "is bound at" <+> pprThBindLevel bind_lvls
+ , text "but used at level" <+> ppr use_lvl]
+ ] ++
+ [hang (text "Could not be resolved by implicit lifting due to the following error:") 2
+ (text "No instance for:" <+> quotes (ppr (errorItemPred item)))
+ | Just item <- [lift_attempt]
+ ] ++
+ [ vcat (text "Available from the imports:" : ppr_imports (gre_imp gre))
+ | LevelCheckSplice _ (Just gre) <- [reason]
+ , not (isEmptyBag (gre_imp gre)) ]
+ where
+ ppr_imports :: Bag ImportSpec -> [SDoc]
+ ppr_imports = map ((bullet <+>) . ppr ) . bagToList
note :: SDoc -> SDoc
note note = "Note" <> colon <+> note <> dot
@@ -4537,8 +4539,7 @@ pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra)
: pp_givens useful_givens)
supplementary = case mb_extra of
- Nothing
- -> Left []
+ Nothing -> Right empty
Just (CND_Extra level ty1 ty2)
-> mk_supplementary_ea_msg ctxt level ty1 ty2 orig
ct_loc = errorItemCtLoc item
@@ -7491,6 +7492,3 @@ pprErrCtxtMsg = \case
text "in" <+> quotes (ppr req_uid) <> dot
--------------------------------------------------------------------------------
-
-pprThBindLevel :: Set.Set ThLevelIndex -> SDoc
-pprThBindLevel levels_set = text "level" <> pluralSet levels_set <+> pprUnquotedSet levels_set
\ No newline at end of file
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -3497,6 +3497,8 @@ data TcRnMessage where
:: !LevelCheckReason -- ^ The binding
-> !(Set.Set ThLevelIndex) -- ^ The binding levels
-> !ThLevelIndex -- ^ The level at which the binding is used.
+ -> !(Maybe ErrorItem) -- ^ The attempt we made to implicitly lift the binding.
+ -> DiagnosticReason -- ^ Whether to defer this error or fail
-> TcRnMessage
{-| TcRnBadlyLevelledWarn is a warning that occurs when a TH type binding is
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -54,6 +54,7 @@ import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Tc.Gen.Expr
+import GHC.Tc.Gen.Head
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Env
import GHC.Tc.Types.Origin
@@ -720,8 +721,8 @@ tcUntypedBracket rn_expr brack ps res_ty
-- Match the expected type with the type of all the internal
-- splices. They might have further constrained types and if they do
-- we want to reflect that in the overall type of the bracket.
- ; ps' <- case quoteWrapperTyVarTy <$> brack_info of
- Just m_var -> mapM (tcPendingSplice m_var) ps
+ ; ps' <- case brack_info of
+ Just q -> mapM (tcPendingSplice q) ps
Nothing -> assert (null ps) $ return []
-- Notice that we don't attempt to typecheck the body
@@ -781,11 +782,11 @@ brackTy b =
---------------
-- | Typechecking a pending splice from a untyped bracket
-tcPendingSplice :: TcType -- Metavariable for the expected overall type of the
+tcPendingSplice :: QuoteWrapper -- Metavariable for the expected overall type of the
-- quotation.
-> PendingRnSplice
-> TcM PendingTcSplice
-tcPendingSplice m_var (PendingRnSplice flavour splice_name expr)
+tcPendingSplice (QuoteWrapper _ m_var) (PendingRnSplice flavour splice_name expr)
-- See Note [Typechecking Overloaded Quotes]
= do { meta_ty <- tcMetaTy meta_ty_name
-- Expected type of splice, e.g. m Exp
@@ -799,6 +800,26 @@ tcPendingSplice m_var (PendingRnSplice flavour splice_name expr)
UntypedPatSplice -> patTyConName
UntypedTypeSplice -> typeTyConName
UntypedDeclSplice -> decsTyConName
+ -- Identifiers that are lifted implicitly, such as 'x' in
+ -- E.g. \x -> [| h x |]
+ -- We must behave as if the reference to x was
+ -- h $(lift x)
+ -- We use 'x' itself as the SplicePointName, used by
+ -- the desugarer to stitch it all back together.
+ -- If 'x' occurs many times we may get many identical
+ -- bindings of the same SplicePointName, but that doesn't
+ -- matter, although it's a mite untidy.
+tcPendingSplice q (PendingImplicitLift bound used gre id_name)
+ = do { (id_expr, id_ty) <- tcInferId id_name
+ -- lift :: Quote m' => a -> m' Exp
+ ; lift <- setSrcSpan (getLocA id_name) $
+ newMethodFromName (ImplicitLiftOrigin bound used gre (getName id_name))
+ GHC.Builtin.Names.TH.liftName
+ [getRuntimeRep id_ty, id_ty]
+ ; let res = nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) (noLocA id_expr)
+
+ ; return (PendingTcSplice (getName id_name) res) }
+
---------------
-- Takes a m and tau and returns the type m (TExp tau)
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -1652,7 +1652,7 @@ checkCrossLevelClsInst dflags reason bind_lvls use_lvl_idx is_local
-- With ImplicitStagePersistence, using later than bound is fine
| xopt LangExt.ImplicitStagePersistence dflags
, any (use_lvl_idx >=) bind_lvls = return ()
- | otherwise = TcM.addErrTc (TcRnBadlyLevelled reason bind_lvls use_lvl_idx)
+ | otherwise = TcM.addErrTc (TcRnBadlyLevelled reason bind_lvls use_lvl_idx Nothing ErrorWithoutFlag)
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -80,11 +80,13 @@ import GHC.Utils.Monad
import GHC.Utils.Misc( HasDebugCallStack )
import GHC.Types.Unique
import GHC.Types.Unique.Supply
+import GHC.Types.ThLevelIndex
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import qualified Data.Kind as Hs
import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.Set as S
{- *********************************************************************
* *
@@ -647,6 +649,7 @@ data CtOrigin
Type -- the instance-sig type
Type -- the instantiated type of the method
| AmbiguityCheckOrigin UserTypeCtxt
+ | ImplicitLiftOrigin (S.Set ThLevelIndex) ThLevelIndex (Maybe GlobalRdrElt) Name
data NonLinearPatternReason
= LazyPatternReason
@@ -944,6 +947,7 @@ pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)]
pprCtO (OmittedFieldOrigin Nothing) = text "an omitted anonymous field"
pprCtO (OmittedFieldOrigin (Just fl)) = hsep [text "omitted field" <+> quotes (ppr fl)]
pprCtO BracketOrigin = text "a quotation bracket"
+pprCtO (ImplicitLiftOrigin _ _ _ n) = text "an implicit lift of" <+> quotes (ppr n)
-- These ones are handled by pprCtOrigin, but we nevertheless sometimes
-- get here via callStackOriginFS, when doing ambiguity checks
@@ -978,7 +982,6 @@ pprNonLinearPatternReason PatternSynonymReason = parens (text "pattern synonyms
pprNonLinearPatternReason ViewPatternReason = parens (text "view patterns aren't linear")
pprNonLinearPatternReason OtherPatternReason = empty
-
{- *********************************************************************
* *
CallStacks and CtOrigin
=====================================
compiler/GHC/Types/ThLevelIndex.hs
=====================================
@@ -3,9 +3,10 @@ module GHC.Types.ThLevelIndex where
import GHC.Prelude
import GHC.Utils.Outputable
import GHC.Types.Basic ( ImportLevel(..) )
-
+import Data.Data (Data)
+import qualified Data.Set as Set
-- | The integer which represents the level
-newtype ThLevelIndex = ThLevelIndex Int deriving (Eq, Ord)
+newtype ThLevelIndex = ThLevelIndex Int deriving (Eq, Ord, Data)
-- NB: see Note [Template Haskell levels] in GHC.Tc.Gen.Splice
-- Incremented when going inside a bracket,
-- decremented when going inside a splice
@@ -32,4 +33,7 @@ quoteLevelIndex = incThLevelIndex topLevelIndex
thLevelIndexFromImportLevel :: ImportLevel -> ThLevelIndex
thLevelIndexFromImportLevel NormalLevel = topLevelIndex
thLevelIndexFromImportLevel SpliceLevel = spliceLevelIndex
-thLevelIndexFromImportLevel QuoteLevel = quoteLevelIndex
\ No newline at end of file
+thLevelIndexFromImportLevel QuoteLevel = quoteLevelIndex
+
+pprThBindLevel :: Set.Set ThLevelIndex -> SDoc
+pprThBindLevel levels_set = text "level" <> pluralSet levels_set <+> pprUnquotedSet levels_set
\ No newline at end of file
=====================================
testsuite/tests/quotes/LiftErrMsg.hs
=====================================
@@ -0,0 +1,27 @@
+{-# LANGUAGE NoImplicitStagePersistence #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module LiftErrMsg where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+data B = B
+
+local_b :: [B]
+local_b = [B]
+
+test :: Q Exp
+test = [| id |]
+
+test2 :: Q Exp
+test2 = [| (id, id) |]
+
+test3 :: Q Exp
+test3 = [| local_b |]
+
+test4 :: a -> Q Exp
+test4 x = [| x |]
+
+test5 :: Lift a => a -> Q Exp
+test5 x = [| x |]
+
=====================================
testsuite/tests/quotes/LiftErrMsg.stderr
=====================================
@@ -0,0 +1,38 @@
+LiftErrMsg.hs:14:11: error: [GHC-28914]
+ • Level error: ‘id’ is bound at level 0 but used at level 1
+ • Could not be resolved by implicit lifting due to the following error:
+ No instance for: ‘Lift (forall a. a -> a)’
+ • Available from the imports:
+ • imported from ‘Prelude’ at LiftErrMsg.hs:3:8-17
+ • In the expression:
+ [| id |]
+ pending(rn) [implicit lift: id]
+ In an equation for ‘test’:
+ test
+ = [| id |]
+ pending(rn) [implicit lift: id]
+
+LiftErrMsg.hs:20:12: error: [GHC-28914]
+ • Level error: ‘local_b’ is bound at level 0 but used at level 1
+ • Could not be resolved by implicit lifting due to the following error:
+ No instance for: ‘Lift B’
+ • In the expression:
+ [| local_b |]
+ pending(rn) [implicit lift: local_b]
+ In an equation for ‘test3’:
+ test3
+ = [| local_b |]
+ pending(rn) [implicit lift: local_b]
+
+LiftErrMsg.hs:23:14: error: [GHC-28914]
+ • Level error: ‘x’ is bound at level 0 but used at level 1
+ • Could not be resolved by implicit lifting due to the following error:
+ No instance for: ‘Lift a’
+ • In the expression:
+ [| x |]
+ pending(rn) [implicit lift: x]
+ In an equation for ‘test4’:
+ test4 x
+ = [| x |]
+ pending(rn) [implicit lift: x]
+
=====================================
testsuite/tests/quotes/LiftErrMsgDefer.hs
=====================================
@@ -0,0 +1,26 @@
+{-# LANGUAGE NoImplicitStagePersistence #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module Main where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+data B = B
+
+local_b :: [B]
+local_b = [B]
+
+test1 :: Q Exp
+test1 = [| id |]
+
+test2 :: Q Exp
+test2 = [| (id, id) |]
+
+test3 :: Q Exp
+test3 = [| local_b |]
+
+main = do
+ runQ test1
+ runQ test2
+ runQ test3
+ return ()
=====================================
testsuite/tests/quotes/LiftErrMsgDefer.stderr
=====================================
@@ -0,0 +1,22 @@
+LiftErrMsgDefer: Uncaught exception ghc-internal:GHC.Internal.Control.Exception.Base.TypeError:
+
+LiftErrMsgDefer.hs:14:12: warning: [GHC-28914] [-Wdeferred-type-errors (in -Wdefault)]
+ • Level error: ‘id’ is bound at level 0 but used at level 1
+ • Could not be resolved by implicit lifting due to the following error:
+ No instance for: ‘Lift (forall a. a -> a)’
+ • Available from the imports:
+ • imported from ‘Prelude’ at LiftErrMsgDefer.hs:3:8-11
+ • In the expression:
+ [| id |]
+ pending(rn) [implicit lift: id]
+ In an equation for ‘test1’:
+ test1
+ = [| id |]
+ pending(rn) [implicit lift: id]
+(deferred type error)
+
+HasCallStack backtrace:
+ collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:169:13 in ghc-internal:GHC.Internal.Exception
+ toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:89:42 in ghc-internal:GHC.Internal.Exception
+ throw, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:435:30 in ghc-internal:GHC.Internal.Control.Exception.Base
+
=====================================
testsuite/tests/quotes/all.T
=====================================
@@ -43,3 +43,5 @@ test('T20893', normal, compile_and_run, [''])
test('T21619', normal, compile, [''])
test('T20472_quotes', normal, compile, [''])
test('T24750', normal, compile_and_run, [''])
+test('LiftErrMsg', normal, compile_fail, [''])
+test('LiftErrMsgDefer', [exit_code(1)], compile_and_run, ['-fdefer-type-errors'])
=====================================
testsuite/tests/th/TH_Lift.stderr
=====================================
@@ -1,161 +1,161 @@
TH_Lift.hs:18:6-39: Splicing expression
(\ x
-> [| x |]
- pending(rn) [
participants (1)
-
Matthew Pickering (＠mpickering)