[Git][ghc/ghc][master] 2 commits: Show an error when we cannot default a concrete tyvar
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sun Apr 16 22:12:08 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00
Show an error when we cannot default a concrete tyvar
Fixes #23153
- - - - -
bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00
Handle ConcreteTvs in inferResultToType
inferResultToType was discarding the ir_frr information, which meant
some metavariables ended up being MetaTvs instead of ConcreteTvs.
This function now creates new ConcreteTvs as necessary, instead of
always creating MetaTvs.
Fixes #23154
- - - - -
17 changed files:
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/Concrete.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/Zonk.hs
- compiler/GHC/Types/Error/Codes.hs
- testsuite/tests/rep-poly/RepPolyInferPatBind.stderr
- testsuite/tests/rep-poly/RepPolyInferPatSyn.stderr
- testsuite/tests/rep-poly/RepPolyPatBind.stderr
- + testsuite/tests/rep-poly/T23153.hs
- + testsuite/tests/rep-poly/T23153.stderr
- + testsuite/tests/rep-poly/T23154.hs
- + testsuite/tests/rep-poly/T23154.stderr
- testsuite/tests/rep-poly/all.T
- testsuite/tests/typecheck/should_fail/VtaFail.stderr
Changes:
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1728,6 +1728,11 @@ instance Diagnostic TcRnMessage where
in ppr (getSrcSpan n) <> colon <+> ppr (tyConName tc)
<+> text "from external module"
+ TcRnCannotDefaultConcrete frr
+ -> mkSimpleDecorated $
+ ppr (frr_context frr) $$
+ text "cannot be assigned a fixed runtime representation," <+>
+ text "not even by defaulting."
diagnosticReason = \case
TcRnUnknownMessage m
@@ -2300,6 +2305,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnTypeSynonymCycle{}
-> ErrorWithoutFlag
+ TcRnCannotDefaultConcrete{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -2899,6 +2906,8 @@ instance Diagnostic TcRnMessage where
-> [suggestExtension LangExt.DataKinds]
TcRnTypeSynonymCycle{}
-> noHints
+ TcRnCannotDefaultConcrete{}
+ -> [SuggestAddTypeSignatures UnnamedBinding]
diagnosticCode = constructorCode
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -3473,6 +3473,15 @@ data TcRnMessage where
-> ![LIdP GhcRn] -- ^ The LHS args
-> !PatSynInvalidRhsReason -- ^ The number of equation arguments
-> TcRnMessage
+ {-| TcRnCannotDefaultConcrete is an error occurring when a concrete
+ type variable cannot be defaulted.
+
+ Test cases:
+ T23153
+ -}
+ TcRnCannotDefaultConcrete
+ :: !FixedRuntimeRepOrigin
+ -> TcRnMessage
{-| TcRnMultiAssocTyFamDefaults is an error indicating that multiple default
declarations were specified for an associated type family.
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -883,7 +883,7 @@ tcExprWithSig expr hs_ty
loc = getLocA (dropWildCards hs_ty)
ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty)
-tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)
+tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
= setSrcSpan loc $ -- Sets the location for the implication constraint
do { let poly_ty = idType poly_id
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -2119,14 +2119,17 @@ checkTouchableTyVarEq ev lhs_tv rhs
; if not (cterHasNoProblem reason) -- Failed to promote free vars
then failCheckWith reason
else
- do { let tv_info | isConcreteInfo lhs_tv_info = lhs_tv_info
- | otherwise = TauTv
- -- Make a concrete tyvar if lhs_tv is concrete
- -- e.g. alpha[2,conc] ~ Maybe (F beta[4])
- -- We want to flatten to
- -- alpha[2,conc] ~ Maybe gamma[2,conc]
- -- gamma[2,conc] ~ F beta[4]
- ; new_tv_ty <- TcM.newMetaTyVarTyWithInfo lhs_tv_lvl tv_info fam_app_kind
+ do { new_tv_ty <-
+ case lhs_tv_info of
+ ConcreteTv conc_info ->
+ -- Make a concrete tyvar if lhs_tv is concrete
+ -- e.g. alpha[2,conc] ~ Maybe (F beta[4])
+ -- We want to flatten to
+ -- alpha[2,conc] ~ Maybe gamma[2,conc]
+ -- gamma[2,conc] ~ F beta[4]
+ TcM.newConcreteTyVarTyAtLevel conc_info lhs_tv_lvl fam_app_kind
+ _ -> TcM.newMetaTyVarTyAtLevel lhs_tv_lvl fam_app_kind
+
; let pty = mkPrimEqPredRole Nominal fam_app new_tv_ty
; hole <- TcM.newCoercionHole pty
; let new_ev = CtWanted { ctev_pred = pty
=====================================
compiler/GHC/Tc/Utils/Concrete.hs
=====================================
@@ -8,9 +8,6 @@ module GHC.Tc.Utils.Concrete
( -- * Ensuring that a type has a fixed runtime representation
hasFixedRuntimeRep
, hasFixedRuntimeRep_syntactic
-
- -- * Making a type concrete
- , makeTypeConcrete
)
where
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -24,7 +25,7 @@ module GHC.Tc.Utils.TcMType (
newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind,
newOpenBoxedTypeKind,
newMetaKindVar, newMetaKindVars,
- newMetaTyVarTyAtLevel, newMetaTyVarTyWithInfo,
+ newMetaTyVarTyAtLevel, newConcreteTyVarTyAtLevel,
newAnonMetaTyVar, newConcreteTyVar,
cloneMetaTyVar, cloneMetaTyVarWithInfo,
newCycleBreakerTyVar,
@@ -482,7 +483,16 @@ newInferExpType :: TcM ExpType
newInferExpType = new_inferExpType Nothing
newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR
-newInferExpTypeFRR frr_orig = new_inferExpType (Just frr_orig)
+newInferExpTypeFRR frr_orig
+ = do { th_stage <- getStage
+ ; if
+ -- See [Wrinkle: Typed Template Haskell]
+ -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
+ | Brack _ (TcPending {}) <- th_stage
+ -> new_inferExpType Nothing
+
+ | otherwise
+ -> new_inferExpType (Just frr_orig) }
new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType
new_inferExpType mb_frr_orig
@@ -538,20 +548,28 @@ expTypeToType (Infer inf_res) = inferResultToType inf_res
inferResultToType :: InferResult -> TcM Type
inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl
- , ir_ref = ref })
+ , ir_ref = ref
+ , ir_frr = mb_frr })
= do { mb_inferred_ty <- readTcRef ref
; tau <- case mb_inferred_ty of
Just ty -> do { ensureMonoType ty
-- See Note [inferResultToType]
; return ty }
- Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
- ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)
- -- See Note [TcLevel of ExpType]
+ Nothing -> do { tau <- new_meta
; writeMutVar ref (Just tau)
; return tau }
; traceTc "Forcing ExpType to be monomorphic:"
(ppr u <+> text ":=" <+> ppr tau)
; return tau }
+ where
+ -- See Note [TcLevel of ExpType]
+ new_meta = case mb_frr of
+ Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
+ ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) }
+ Just frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy
+ ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)
+ ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr
+ ; return tau }
{- Note [inferResultToType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -874,6 +892,13 @@ newTauTvDetailsAtLevel tclvl
, mtv_ref = ref
, mtv_tclvl = tclvl }) }
+newConcreteTvDetailsAtLevel :: ConcreteTvOrigin -> TcLevel -> TcM TcTyVarDetails
+newConcreteTvDetailsAtLevel conc_orig tclvl
+ = do { ref <- newMutVar Flexi
+ ; return (MetaTv { mtv_info = ConcreteTv conc_orig
+ , mtv_ref = ref
+ , mtv_tclvl = tclvl }) }
+
cloneMetaTyVar :: TcTyVar -> TcM TcTyVar
cloneMetaTyVar tv
= assert (isTcTyVar tv) $
@@ -931,7 +956,7 @@ isUnfilledMetaTyVar tv
--------------------
-- Works with both type and kind variables
-writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
+writeMetaTyVar :: HasDebugCallStack => TcTyVar -> TcType -> TcM ()
-- Write into a currently-empty MetaTyVar
writeMetaTyVar tyvar ty
@@ -949,7 +974,7 @@ writeMetaTyVar tyvar ty
= massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar)
--------------------
-writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
+writeMetaTyVarRef :: HasDebugCallStack => TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
-- Here the tyvar is for error checking only;
-- the ref cell must be for the same tyvar
writeMetaTyVarRef tyvar ref ty
@@ -1114,13 +1139,10 @@ newMetaTyVarTyAtLevel tc_lvl kind
; name <- newMetaTyVarName (fsLit "p")
; return (mkTyVarTy (mkTcTyVar name kind details)) }
-newMetaTyVarTyWithInfo :: TcLevel -> MetaInfo -> TcKind -> TcM TcType
-newMetaTyVarTyWithInfo tc_lvl info kind
- = do { ref <- newMutVar Flexi
- ; let details = MetaTv { mtv_info = info
- , mtv_ref = ref
- , mtv_tclvl = tc_lvl }
- ; name <- newMetaTyVarName (fsLit "p")
+newConcreteTyVarTyAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType
+newConcreteTyVarTyAtLevel conc_orig tc_lvl kind
+ = do { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl
+ ; name <- newMetaTyVarName (fsLit "c")
; return (mkTyVarTy (mkTcTyVar name kind details)) }
{- *********************************************************************
@@ -2258,7 +2280,7 @@ a \/\a in the final result but all the occurrences of a will be zonked to ()
* *
********************************************************************* -}
-promoteMetaTyVarTo :: TcLevel -> TcTyVar -> TcM Bool
+promoteMetaTyVarTo :: HasDebugCallStack => TcLevel -> TcTyVar -> TcM Bool
-- When we float a constraint out of an implication we must restore
-- invariant (WantedInv) in Note [TcLevel invariants] in GHC.Tc.Utils.TcType
-- Return True <=> we did some promotion
@@ -2276,7 +2298,7 @@ promoteMetaTyVarTo tclvl tv
= return False
-- Returns whether or not *any* tyvar is defaulted
-promoteTyVarSet :: TcTyVarSet -> TcM Bool
+promoteTyVarSet :: HasDebugCallStack => TcTyVarSet -> TcM Bool
promoteTyVarSet tvs
= do { tclvl <- getTcLevel
; bools <- mapM (promoteMetaTyVarTo tclvl) $
=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -56,6 +56,7 @@ import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.Env ( tcLookupGlobalOnly )
import GHC.Tc.Types.Evidence
+import GHC.Tc.Errors.Types
import GHC.Core.TyCo.Ppr ( pprTyVar )
import GHC.Core.TyCon
@@ -1737,7 +1738,7 @@ change. But in some cases it makes a HUGE difference: see test
T9198 and #19668. So yes, it seems worth it.
-}
-zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Type
+zonkTyVarOcc :: HasDebugCallStack => ZonkEnv -> TcTyVar -> TcM Type
zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi
, ze_tv_env = tv_env
, ze_meta_tv_env = mtv_env_ref }) tv
@@ -1810,6 +1811,9 @@ commitFlexi flexi tv zonked_kind
| isMultiplicityTy zonked_kind
-> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)
; return manyDataConTy }
+ | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv
+ -> do { addErr $ TcRnCannotDefaultConcrete origin
+ ; return (anyTypeOfKind zonked_kind) }
| otherwise
-> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv)
; return (anyTypeOfKind zonked_kind) }
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -480,8 +480,6 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods" = 93006
GhcDiagnosticCode "TcRnHsigFixityMismatch" = 93007
- GhcDiagnosticCode "HsigShapeSortMismatch" = 93008
- GhcDiagnosticCode "HsigShapeNotUnifiable" = 93009
GhcDiagnosticCode "TcRnHsigNoIface" = 93010
GhcDiagnosticCode "TcRnHsigMissingModuleExport" = 93011
GhcDiagnosticCode "TcRnBadGenericMethod" = 59794
@@ -551,8 +549,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnPatSynEscapedCoercion" = 88986
GhcDiagnosticCode "TcRnPatSynExistentialInResult" = 33973
GhcDiagnosticCode "TcRnPatSynArityMismatch" = 18365
- GhcDiagnosticCode "PatSynNotInvertible" = 69317
- GhcDiagnosticCode "PatSynUnboundVar" = 28572
+ GhcDiagnosticCode "TcRnCannotDefaultConcrete" = 52083
GhcDiagnosticCode "TcRnMultiAssocTyFamDefaults" = 59128
GhcDiagnosticCode "TcRnTyFamDepsDisabled" = 43991
GhcDiagnosticCode "TcRnAbstractClosedTyFamDecl" = 60012
@@ -580,6 +577,10 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnTyFamNameMismatch" = 88221
GhcDiagnosticCode "TcRnTypeSynonymCycle" = 97522
+ -- PatSynInvalidRhsReason
+ GhcDiagnosticCode "PatSynNotInvertible" = 69317
+ GhcDiagnosticCode "PatSynUnboundVar" = 28572
+
-- TcRnBadFieldAnnotation/BadFieldAnnotationReason
GhcDiagnosticCode "LazyFieldsDisabled" = 81601
GhcDiagnosticCode "UnpackWithoutStrictness" = 10107
@@ -601,6 +602,10 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnPrecedenceParsingError" = 88747
GhcDiagnosticCode "TcRnSectionPrecedenceError" = 46878
+ -- HsigShapeMismatchReason
+ GhcDiagnosticCode "HsigShapeSortMismatch" = 93008
+ GhcDiagnosticCode "HsigShapeNotUnifiable" = 93009
+
-- IllegalNewtypeReason
GhcDiagnosticCode "DoesNotHaveSingleField" = 23517
GhcDiagnosticCode "IsNonLinear" = 38291
=====================================
testsuite/tests/rep-poly/RepPolyInferPatBind.stderr
=====================================
@@ -8,7 +8,7 @@ RepPolyInferPatBind.hs:21:2: error: [GHC-55287]
• The pattern binding does not have a fixed runtime representation.
Its type is:
T :: TYPE R
- Cannot unify ‘R’ with the type variable ‘p0’
+ Cannot unify ‘R’ with the type variable ‘c0’
because it is not a concrete ‘RuntimeRep’.
• When checking that the pattern signature: T
fits the type of its context: T
=====================================
testsuite/tests/rep-poly/RepPolyInferPatSyn.stderr
=====================================
@@ -4,7 +4,7 @@ RepPolyInferPatSyn.hs:22:16: error: [GHC-55287]
does not have a fixed runtime representation.
Its type is:
T :: TYPE R
- Cannot unify ‘R’ with the type variable ‘p0’
+ Cannot unify ‘R’ with the type variable ‘c0’
because it is not a concrete ‘RuntimeRep’.
• When checking that the pattern signature: T
fits the type of its context: T
=====================================
testsuite/tests/rep-poly/RepPolyPatBind.stderr
=====================================
@@ -1,4 +1,20 @@
+RepPolyPatBind.hs:18:5: error: [GHC-55287]
+ • The pattern binding does not have a fixed runtime representation.
+ Its type is:
+ p0 :: TYPE c0
+ Cannot unify ‘TupleRep [rep, rep]’ with the type variable ‘c0’
+ because it is not a concrete ‘RuntimeRep’.
+ • In the pattern: (# x, y #)
+ In a pattern binding: (# x, y #) = undefined
+ In the expression:
+ let
+ x, y :: a
+ (# x, y #) = undefined
+ in x
+ • Relevant bindings include
+ foo :: () -> a (bound at RepPolyPatBind.hs:15:1)
+
RepPolyPatBind.hs:18:5: error: [GHC-55287]
• • The binder ‘y’ does not have a fixed runtime representation.
Its type is:
=====================================
testsuite/tests/rep-poly/T23153.hs
=====================================
@@ -0,0 +1,8 @@
+module T23153 where
+
+import GHC.Exts
+
+f :: forall r s (a :: TYPE (r s)). a -> ()
+f = f
+
+g h = f (h ())
=====================================
testsuite/tests/rep-poly/T23153.stderr
=====================================
@@ -0,0 +1,15 @@
+
+T23153.hs:8:1: error: [GHC-52083]
+ The argument ‘(h ())’ of ‘f’
+ cannot be assigned a fixed runtime representation, not even by defaulting.
+ Suggested fix: Add a type signature.
+
+T23153.hs:8:1: error: [GHC-52083]
+ The argument ‘(h ())’ of ‘f’
+ cannot be assigned a fixed runtime representation, not even by defaulting.
+ Suggested fix: Add a type signature.
+
+T23153.hs:8:1: error: [GHC-52083]
+ The argument ‘(h ())’ of ‘f’
+ cannot be assigned a fixed runtime representation, not even by defaulting.
+ Suggested fix: Add a type signature.
=====================================
testsuite/tests/rep-poly/T23154.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+
+module T23154 where
+
+import GHC.Exts
+
+f x = x :: (_ :: (TYPE (_ _)))
=====================================
testsuite/tests/rep-poly/T23154.stderr
=====================================
@@ -0,0 +1,10 @@
+
+T23154.hs:7:1: error: [GHC-52083]
+ The first pattern in the equation for ‘f’
+ cannot be assigned a fixed runtime representation, not even by defaulting.
+ Suggested fix: Add a type signature.
+
+T23154.hs:7:1: error: [GHC-52083]
+ The first pattern in the equation for ‘f’
+ cannot be assigned a fixed runtime representation, not even by defaulting.
+ Suggested fix: Add a type signature.
=====================================
testsuite/tests/rep-poly/all.T
=====================================
@@ -116,3 +116,5 @@ test('T21650_b', normal, compile_fail, ['-Wno-deprecated-flags']) ##
test('T23051', normal, compile_fail, [''])
+test('T23153', normal, compile_fail, [''])
+test('T23154', normal, compile_fail, [''])
=====================================
testsuite/tests/typecheck/should_fail/VtaFail.stderr
=====================================
@@ -7,7 +7,7 @@ VtaFail.hs:7:16: error: [GHC-95781]
answer_nosig = pairup_nosig @Int @Bool 5 True
VtaFail.hs:14:17: error: [GHC-95781]
- • Cannot apply expression of type ‘p1 -> p1’
+ • Cannot apply expression of type ‘p0 -> p0’
to a visible type argument ‘Int’
• In the expression: (\ x -> x) @Int 12
In an equation for ‘answer_lambda’:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c04024617f1ee4c76844cfe0a886bab87c23bd0...bad2f8b8aa84241e523577062e2b69090efccb32
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c04024617f1ee4c76844cfe0a886bab87c23bd0...bad2f8b8aa84241e523577062e2b69090efccb32
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/20230416/71267524/attachment-0001.html>
More information about the ghc-commits
mailing list