Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: c85c845d by sheaf at 2025-10-17T22:35:32-04:00 Don't prematurely final-zonk PatSyn declarations This commit makes GHC hold off on the final zonk for pattern synonym declarations, in 'GHC.Tc.TyCl.PatSyn.tc_patsyn_finish'. This accommodates the fact that pattern synonym declarations without a type signature can contain unfilled metavariables, e.g. if the RHS of the pattern synonym involves view-patterns whose type mentions promoted (level 0) metavariables. Just like we do for ordinary function bindings, we should allow these metavariables to be settled later, instead of eagerly performing a final zonk-to-type. Now, the final zonking-to-type for pattern synonyms is performed in GHC.Tc.Module.zonkTcGblEnv. Fixes #26465 - - - - - 16 changed files: - compiler/GHC/Core/Make.hs - compiler/GHC/Core/PatSyn.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/Language/Haskell/Syntax/Binds.hs - + testsuite/tests/patsyn/should_compile/T26465b.hs - + testsuite/tests/patsyn/should_compile/T26465c.hs - + testsuite/tests/patsyn/should_compile/T26465d.hs - + testsuite/tests/patsyn/should_compile/T26465d.stderr - testsuite/tests/patsyn/should_compile/all.T - + testsuite/tests/patsyn/should_fail/T26465.hs - + testsuite/tests/patsyn/should_fail/T26465.stderr - testsuite/tests/patsyn/should_fail/all.T - testsuite/tests/th/T8761.stderr Changes: ===================================== compiler/GHC/Core/Make.hs ===================================== @@ -111,7 +111,7 @@ sortQuantVars vs = sorted_tcvs ++ ids -- | Bind a binding group over an expression, using a @let@ or @case@ as -- appropriate (see "GHC.Core#let_can_float_invariant") -mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr +mkCoreLet :: HasDebugCallStack => CoreBind -> CoreExpr -> CoreExpr mkCoreLet (NonRec bndr rhs) body -- See Note [Core let-can-float invariant] = bindNonRec bndr rhs body mkCoreLet bind body @@ -133,7 +133,7 @@ mkCoreTyLams binders body = mkCast lam co -- | Bind a list of binding groups over an expression. The leftmost binding -- group becomes the outermost group in the resulting expression -mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr +mkCoreLets :: HasDebugCallStack => [CoreBind] -> CoreExpr -> CoreExpr mkCoreLets binds body = foldr mkCoreLet body binds -- | Construct an expression which represents the application of a number of ===================================== compiler/GHC/Core/PatSyn.hs ===================================== @@ -9,7 +9,7 @@ module GHC.Core.PatSyn ( -- * Main data types - PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn, + PatSyn(..), PatSynMatcher, PatSynBuilder, mkPatSyn, -- ** Type deconstruction patSynName, patSynArity, patSynVisArity, ===================================== compiler/GHC/HsToCore/Utils.hs ===================================== @@ -259,12 +259,12 @@ wrapBind new old body -- NB: this function must deal with term seqVar :: Var -> CoreExpr -> CoreExpr seqVar var body = mkDefaultCase (Var var) var body -mkCoLetMatchResult :: CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr +mkCoLetMatchResult :: HasDebugCallStack => CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr mkCoLetMatchResult bind = fmap (mkCoreLet bind) -- (mkViewMatchResult var' viewExpr mr) makes the expression -- let var' = viewExpr in mr -mkViewMatchResult :: Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr +mkViewMatchResult :: HasDebugCallStack => Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr mkViewMatchResult var' viewExpr = fmap $ mkCoreLet $ NonRec var' viewExpr mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -579,7 +579,7 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls -- Zonk the final code. This must be done last. -- Even simplifyTop may do some unification. -- This pass also warns about missing type signatures - ; (id_env, ev_binds', binds', fords', imp_specs', rules') + ; (id_env, ev_binds', binds', fords', imp_specs', rules', pat_syns') <- zonkTcGblEnv new_ev_binds tcg_env --------- Run finalizers -------------- @@ -597,6 +597,7 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls , tcg_imp_specs = [] , tcg_rules = [] , tcg_fords = [] + , tcg_patsyns = [] , tcg_type_env = tcg_type_env tcg_env `plusTypeEnv` id_env } ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env @@ -628,7 +629,7 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls -- Zonk the new bindings arising from running the finalisers, -- and main. This won't give rise to any more finalisers as you -- can't nest finalisers inside finalisers. - ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) + ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf, patsyns_mf) <- zonkTcGblEnv main_ev_binds tcg_env ; let { !final_type_env = tcg_type_env tcg_env @@ -642,24 +643,26 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls , tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf , tcg_imp_specs = imp_specs' ++ imp_specs_mf , tcg_rules = rules' ++ rules_mf - , tcg_fords = fords' ++ fords_mf } } ; + , tcg_fords = fords' ++ fords_mf + , tcg_patsyns = pat_syns' ++ patsyns_mf } } ; ; setGlobalTypeEnv tcg_env' final_type_env } zonkTcGblEnv :: Bag EvBind -> TcGblEnv -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, - [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc]) + [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc], [PatSyn]) zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds = binds , tcg_ev_binds = cur_ev_binds , tcg_imp_specs = imp_specs , tcg_rules = rules - , tcg_fords = fords }) + , tcg_fords = fords + , tcg_patsyns = pat_syns }) = {-# SCC "zonkTopDecls" #-} setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering -- error messages during zonking (notably levity errors) do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds - ; zonkTopDecls all_ev_binds binds rules imp_specs fords } + ; zonkTopDecls all_ev_binds binds rules imp_specs fords pat_syns } -- | Runs TH finalizers and renames and typechecks the top-level declarations -- that they could introduce. ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -23,7 +23,6 @@ import GHC.Hs import GHC.Tc.Gen.Pat import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType -import GHC.Tc.Zonk.Type import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Zonk.TcType @@ -37,10 +36,10 @@ import GHC.Tc.Types.Origin import GHC.Tc.TyCl.Build import GHC.Core.Multiplicity -import GHC.Core.Type ( typeKind, isManyTy, mkTYPEapp ) +import GHC.Core.Type ( typeKind, isManyTy, mkTYPEapp, definitelyLiftedType ) import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) -import GHC.Core.TyCo.Tidy( tidyForAllTyBinders, tidyTypes, tidyType ) import GHC.Core.Predicate +import GHC.Core.TyCo.Tidy import GHC.Types.Name import GHC.Types.Name.Reader @@ -51,7 +50,7 @@ import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.Var -import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSetList ) +import GHC.Types.Var.Env( mkInScopeSetList, emptyTidyEnv ) import GHC.Types.Id import GHC.Types.Id.Info( RecSelParent(..) ) import GHC.Tc.Gen.Bind @@ -672,27 +671,31 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty field_labels - = do { -- Zonk everything. We are about to build a final PatSyn - -- so there had better be no unification variables in there - - (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, pat_ty) <- - initZonkEnv NoFlexi $ - runZonkBndrT (zonkTyVarBindersX univ_tvs) $ \ univ_tvs' -> - do { req_theta' <- zonkTcTypesToTypesX req_theta - ; runZonkBndrT (zonkTyVarBindersX ex_tvs) $ \ ex_tvs' -> - do { prov_theta' <- zonkTcTypesToTypesX prov_theta - ; pat_ty' <- zonkTcTypeToTypeX pat_ty - ; arg_tys' <- zonkTcTypesToTypesX arg_tys + = do { -- Don't do a final zonk-to-type yet, as the pattern synonym may still + -- contain unfilled metavariables. + -- See Note [Metavariables in pattern synonyms]. + + -- We still need to zonk, however, in order for instantiation to work + -- correctly. If we don't zonk, we are at risk of quantifying + -- 'alpha -> beta' to 'forall a. a -> beta' even though 'beta := alpha'. + ; (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, pat_ty) <- + liftZonkM $ + do { univ_tvs' <- traverse zonkInvisTVBinder univ_tvs + ; req_theta' <- zonkTcTypes req_theta + ; ex_tvs' <- traverse zonkInvisTVBinder ex_tvs + ; prov_theta' <- zonkTcTypes prov_theta + ; pat_ty' <- zonkTcType pat_ty + ; arg_tys' <- zonkTcTypes arg_tys ; let (env1, univ_tvs) = tidyForAllTyBinders emptyTidyEnv univ_tvs' + req_theta = tidyTypes env1 req_theta' (env2, ex_tvs) = tidyForAllTyBinders env1 ex_tvs' - req_theta = tidyTypes env2 req_theta' prov_theta = tidyTypes env2 prov_theta' arg_tys = tidyTypes env2 arg_tys' pat_ty = tidyType env2 pat_ty' ; return (univ_tvs, req_theta, - ex_tvs, prov_theta, arg_tys, pat_ty) } } + ex_tvs, prov_theta, arg_tys, pat_ty) } ; traceTc "tc_patsyn_finish {" $ ppr (unLoc lname) $$ ppr (unLoc lpat') $$ @@ -734,6 +737,48 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn ; traceTc "tc_patsyn_finish }" empty ; return (matcher_bind, tcg_env) } +{- Note [Metavariables in pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unlike data constructors, the types of pattern synonyms are allowed to contain +metavariables, because of view patterns. Example (from ticket #26465): + + f :: Eq a => a -> Maybe a + f = ... + + g = f + -- Due to the monomorphism restriction, we infer + -- g :: alpha -> Maybe alpha, with [W] Eq alpha + + pattern P x <- (g -> Just x) + -- Infer: P :: alpha -> alpha + +Note that: + + 1. 'g' is a top-level function binding whose inferred type contains metavariables + (due to type variable promotion, as described in Note [Deciding quantification] in GHC.Tc.Solver) + 2. 'P' is a pattern synonym without a type signature which uses 'g' in a view pattern. + +In this way, promoted metavariables of top-level functions can sneak their way +into pattern synonym definitions. + +To account for this fact, we do not attempt a final zonk-to-type in +'GHC.Tc.TyCl.PatSyn.tc_patsyn_finish'. Indeed, GHC may fill in the metavariables +when typechecking the rest of the module. Following on from the above example, +we might have a later binding: + + y = g 'c' + -- fixes alpha := Char + +or + + h (P b) = not b + -- fixes alpha := Bool + +We instead perform the final zonk-to-type at the very end, in the call +to 'GHC.Tc.Zonk.Type.zonkPatSyn' in 'GHC.Tc.Zonk.Type.zonkTopDecls'. In this way, +pattern synonyms are treated the same as top-level function bindings. +-} + {- ************************************************************************ * * @@ -870,9 +915,11 @@ mkPatSynBuilder dir (L _ name) | otherwise = do { builder_name <- newImplicitBinder name mkBuilderOcc ; let theta = req_theta ++ prov_theta - need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta - -- NB: pattern arguments cannot be representation-polymorphic, - -- as checked in 'tcPatSynSig'. So 'isUnliftedType' is OK here. + need_dummy_arg = null arg_tys && null theta && not (definitelyLiftedType pat_ty) + -- At this point, the representation of 'pat_ty' might still be unknown (see T26465c), + -- so use a conservative test that handles an unknown representation. + -- Ideally, we'd defer making the builder until the representation is settled, + -- but that would be a lot more work. builder_sigma = add_void need_dummy_arg $ mkInvisForAllTys univ_bndrs $ mkInvisForAllTys ex_bndrs $ ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -37,9 +37,6 @@ module GHC.Tc.Zonk.Type ( import GHC.Prelude import GHC.Builtin.Types - -import GHC.Core.TyCo.Ppr ( pprTyVar ) - import GHC.Hs import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) @@ -60,8 +57,11 @@ import GHC.Tc.Zonk.TcType , checkCoercionHole , zonkCoVar ) -import GHC.Core.Type import GHC.Core.Coercion +import GHC.Core.ConLike +import GHC.Core.PatSyn (PatSyn(..)) +import GHC.Core.TyCo.Ppr ( pprTyVar ) +import GHC.Core.Type import GHC.Core.TyCon import GHC.Utils.Outputable @@ -93,6 +93,7 @@ import Control.Monad import Control.Monad.Trans.Class ( lift ) import Data.List.NonEmpty ( NonEmpty ) import Data.Foldable ( toList ) +import Data.Traversable ( for ) {- Note [What is zonking?] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -470,7 +471,7 @@ commitFlexi DefaultFlexi tv zonked_kind ; return manyDataConTy } | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv = do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin) - ; return (anyTypeOfKind zonked_kind) } + ; newZonkAnyType zonked_kind } | otherwise = do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv) -- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4) @@ -647,23 +648,25 @@ zonkTopDecls :: Bag EvBind -> LHsBinds GhcTc -> [LRuleDecl GhcTc] -> [LTcSpecPrag] -> [LForeignDecl GhcTc] + -> [PatSyn] -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, [LForeignDecl GhcTc], [LTcSpecPrag], - [LRuleDecl GhcTc]) -zonkTopDecls ev_binds binds rules imp_specs fords + [LRuleDecl GhcTc], + [PatSyn]) +zonkTopDecls ev_binds binds rules imp_specs fords pat_syns = initZonkEnv DefaultFlexi $ runZonkBndrT (zonkEvBinds ev_binds) $ \ ev_binds' -> runZonkBndrT (zonkRecMonoBinds binds) $ \ binds' -> -- Top level is implicitly recursive - do { rules' <- zonkRules rules - ; specs' <- zonkLTcSpecPrags imp_specs - ; fords' <- zonkForeignExports fords - ; ty_env <- zonkEnvIds <$> getZonkEnv - ; return (ty_env, ev_binds', binds', fords', specs', rules') } - + do { rules' <- zonkRules rules + ; specs' <- zonkLTcSpecPrags imp_specs + ; fords' <- zonkForeignExports fords + ; pat_syns' <- traverse zonkPatSyn pat_syns + ; ty_env <- zonkEnvIds <$> getZonkEnv + ; return (ty_env, ev_binds', binds', fords', specs', rules', pat_syns') } --------------------------------------------- zonkLocalBinds :: HsLocalBinds GhcTc @@ -1549,7 +1552,8 @@ zonk_pat (SumPat tys pat alt arity ) ; pat' <- zonkPat pat ; return (SumPat tys' pat' alt arity) } -zonk_pat p@(ConPat { pat_args = args +zonk_pat p@(ConPat { pat_con = L con_loc con + , pat_args = args , pat_con_ext = p'@(ConPatTc { cpt_tvs = tyvars , cpt_dicts = evs @@ -1568,8 +1572,15 @@ zonk_pat p@(ConPat { pat_args = args ; new_binds <- zonkTcEvBinds binds ; new_wrapper <- zonkCoFn wrapper ; new_args <- zonkConStuff args + ; new_con <- case con of + RealDataCon {} -> return con + -- Data constructors never contain metavariables: they are + -- fully zonked before we look at any value bindings. + PatSynCon ps -> PatSynCon <$> noBinders (zonkPatSyn ps) + -- Pattern synonyms can contain metavariables, see e.g. T26465c. ; pure $ p - { pat_args = new_args + { pat_con = L con_loc new_con + , pat_args = new_args , pat_con_ext = p' { cpt_arg_tys = new_tys , cpt_tvs = new_tyvars @@ -1615,14 +1626,14 @@ zonk_pat (InvisPat ty tp) ; return (InvisPat ty' tp) } zonk_pat (XPat ext) = case ext of - { ExpansionPat orig pat-> + { ExpansionPat orig pat -> do { pat' <- zonk_pat pat ; return $ XPat $ ExpansionPat orig pat' } ; CoPat co_fn pat ty -> - do { co_fn' <- zonkCoFn co_fn - ; pat' <- zonkPat (noLocA pat) - ; ty' <- noBinders $ zonkTcTypeToTypeX ty - ; return (XPat $ CoPat co_fn' (unLoc pat') ty') + do { co_fn' <- zonkCoFn co_fn + ; pat' <- zonk_pat pat + ; ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (XPat $ CoPat co_fn' pat' ty') } } zonk_pat pat = pprPanic "zonk_pat" (ppr pat) @@ -1653,6 +1664,45 @@ zonkPats = traverse zonkPat {-# SPECIALISE zonkPats :: [LPat GhcTc] -> ZonkBndrTcM [LPat GhcTc] #-} {-# SPECIALISE zonkPats :: NonEmpty (LPat GhcTc) -> ZonkBndrTcM (NonEmpty (LPat GhcTc)) #-} +--------------------------- + +-- | Perform a final zonk-to-type for a pattern synonym. +-- +-- See Note [Metavariables in pattern synonyms] in GHC.Tc.TyCl.PatSyn. +zonkPatSyn :: PatSyn -> ZonkTcM PatSyn +zonkPatSyn + ps@( MkPatSyn + { psArgs = arg_tys + , psUnivTyVars = univ_tvs + , psReqTheta = req_theta + , psExTyVars = ex_tvs + , psProvTheta = prov_theta + , psResultTy = res_ty + , psMatcher = (matcherNm, matcherTy, matcherDummyArg) + , psBuilder = mbBuilder + }) = + runZonkBndrT (zonkTyVarBindersX univ_tvs) $ \ univ_tvs' -> + do { req_theta' <- zonkTcTypesToTypesX req_theta + ; res_ty' <- zonkTcTypeToTypeX res_ty + ; runZonkBndrT (zonkTyVarBindersX ex_tvs) $ \ ex_tvs' -> + do { prov_theta' <- zonkTcTypesToTypesX prov_theta + ; arg_tys' <- zonkTcTypesToTypesX arg_tys + ; matcherTy' <- zonkTcTypeToTypeX matcherTy + ; mbBuilder' <- for mbBuilder $ \ (builderNm, builderTy, builderDummyArg) -> + do { builderTy' <- zonkTcTypeToTypeX builderTy + ; return (builderNm, builderTy', builderDummyArg) } + ; return $ + ps + { psArgs = arg_tys' + , psUnivTyVars = univ_tvs' + , psReqTheta = req_theta' + , psExTyVars = ex_tvs' + , psProvTheta = prov_theta' + , psResultTy = res_ty' + , psMatcher = (matcherNm, matcherTy', matcherDummyArg) + , psBuilder = mbBuilder' + } } } + {- ************************************************************************ * * ===================================== compiler/Language/Haskell/Syntax/Binds.hs ===================================== @@ -233,7 +233,7 @@ data HsBindLR idL idR var_rhs :: LHsExpr idR -- ^ Located only for consistency } - -- | Patterns Synonym Binding + -- | Pattern Synonym Binding | PatSynBind (XPatSynBind idL idR) (PatSynBind idL idR) ===================================== testsuite/tests/patsyn/should_compile/T26465b.hs ===================================== @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} + +module T26465b where + +-- Variant of T26465 which should be accepted + +f :: Eq a => a -> Maybe a +f _ = Nothing + +-- Monomorphism restriction bites +-- Eq a[tau:0] => a[tau:0] -> Maybe a[tau:0] +g = f + +pattern P x <- ( g -> Just x ) + +x = g (1 :: Int) ===================================== testsuite/tests/patsyn/should_compile/T26465c.hs ===================================== @@ -0,0 +1,45 @@ + +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} + +{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-} + +module T26465c where + +-- Rep-poly variant of T26465b + +import Data.Kind + ( Constraint ) +import GHC.Exts + ( TYPE, Int#, isTrue#, (>=#) ) + + +type HasP :: forall r. TYPE r -> Constraint +class HasP a where + getP :: a -> (# (# #) | (# #) #) + mk :: (# #) -> a + +instance HasP Int where + getP i = if i >= 0 then (# | (# #) #) else (# (# #) | #) + mk _ = 1 +instance HasP Int# where + getP i# = if isTrue# ( i# >=# 0# ) then (# | (# #) #) else (# (# #) | #) + mk _ = 1# + +g1 = getP +g2 = getP + +m1 = mk +m2 = mk + +-- NB: deliberately use no arguments to make this test harder (so that we run +-- into the 'need_dummy_arg' logic of 'GHC.Tc.TyCl.PatSyn.mkPatSynBuilder'). +pattern P1 <- ( g1 -> (# | (# #) #) ) + where P1 = m1 (# #) +pattern P2 <- ( g2 -> (# | (# #) #) ) + where P2 = m2 (# #) + +y1 :: Int -> Int +y1 P1 = P1 + +y2 :: Int# -> Int# +y2 P2 = P2 ===================================== testsuite/tests/patsyn/should_compile/T26465d.hs ===================================== @@ -0,0 +1,28 @@ + +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} + +{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-} + +module T26465d where + +-- Should-fail variant of T26465c (but with -fdefer-type-errors) + +import Data.Kind + ( Constraint ) +import GHC.Exts + ( TYPE ) + +type HasP :: forall r. TYPE r -> Constraint +class HasP a where + getP :: a -> (# (# #) | (# #) #) + mk :: (# #) -> a + +g = getP +m = mk + +-- NB: deliberately use no arguments to make this test harder (so that we run +-- into the 'need_dummy_arg' logic of 'GHC.Tc.TyCl.PatSyn.mkPatSynBuilder'). +pattern P1 <- ( g -> (# | (# #) #) ) + where P1 = m (# #) + +test P1 = P1 ===================================== testsuite/tests/patsyn/should_compile/T26465d.stderr ===================================== @@ -0,0 +1,10 @@ +T26465d.hs:20:5: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)] + • No instance for ‘HasP a0’ arising from a use of ‘getP’ + • In the expression: getP + In an equation for ‘g’: g = getP + +T26465d.hs:21:5: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)] + • No instance for ‘HasP a0’ arising from a use of ‘mk’ + • In the expression: mk + In an equation for ‘m’: m = mk + ===================================== testsuite/tests/patsyn/should_compile/all.T ===================================== @@ -73,6 +73,9 @@ test('T13752a', normal, compile, ['']) test('T13768', normal, compile, ['']) test('T14058', [extra_files(['T14058.hs', 'T14058a.hs'])], multimod_compile, ['T14058', '-v0']) +test('T26465b', normal, compile, ['']) +test('T26465c', normal, compile, ['']) +test('T26465d', normal, compile, ['-fdefer-type-errors']) test('T14326', normal, compile, ['']) test('T14380', normal, compile, ['']) test('T14394', normal, ghci_script, ['T14394.script']) ===================================== testsuite/tests/patsyn/should_fail/T26465.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} + +module T26465 where + +f :: Eq a => a -> Maybe a +f _ = Nothing + +-- Monomorphism restriction bites +-- Eq a[tau:0] => a[tau:0] -> Maybe a[tau:0] +g = f + +pattern P x <- ( g -> Just x ) ===================================== testsuite/tests/patsyn/should_fail/T26465.stderr ===================================== @@ -0,0 +1,15 @@ +T26465.hs:10:5: error: [GHC-39999] + • Ambiguous type variable ‘a0’ arising from a use of ‘f’ + prevents the constraint ‘(Eq a0)’ from being solved. + Relevant bindings include + g :: a0 -> Maybe a0 (bound at T26465.hs:10:1) + Probable fix: use a type annotation to specify what ‘a0’ should be. + Potentially matching instances: + instance Eq Ordering -- Defined in ‘GHC.Internal.Classes’ + instance Eq Integer -- Defined in ‘GHC.Internal.Bignum.Integer’ + ...plus 24 others + ...plus five instances involving out-of-scope types + (use -fprint-potential-instances to see them all) + • In the expression: f + In an equation for ‘g’: g = f + ===================================== testsuite/tests/patsyn/should_fail/all.T ===================================== @@ -35,6 +35,7 @@ test('T12165', normal, compile_fail, ['']) test('T12819', normal, compile_fail, ['']) test('UnliftedPSBind', normal, compile_fail, ['']) test('T15695', normal, compile, ['']) # It has -fdefer-type-errors inside +test('T26465', normal, compile_fail, ['']) test('T13349', normal, compile_fail, ['']) test('T13470', normal, compile_fail, ['']) test('T14112', normal, compile_fail, ['']) ===================================== testsuite/tests/th/T8761.stderr ===================================== @@ -123,29 +123,29 @@ T8761.hs:(71,1)-(105,39): Splicing declarations pattern Puep x y <- (MkExProv y, x) pattern T8761.P :: GHC.Internal.Types.Bool pattern T8761.Pe :: () => forall (a_0 :: *) . a_0 -> T8761.Ex -pattern T8761.Pu :: forall (a_0 :: *) . a_0 -> a_0 -pattern T8761.Pue :: forall (a_0 :: *) . () => forall (b_1 :: *) . - a_0 -> b_1 -> (a_0, T8761.Ex) -pattern T8761.Pur :: forall (a_0 :: *) . (GHC.Internal.Num.Num a_0, - GHC.Internal.Classes.Eq a_0) => - a_0 -> [a_0] -pattern T8761.Purp :: forall (a_0 :: *) (b_1 :: *) . (GHC.Internal.Num.Num a_0, - GHC.Internal.Classes.Eq a_0) => - GHC.Internal.Show.Show b_1 => - a_0 -> b_1 -> ([a_0], T8761.UnivProv b_1) -pattern T8761.Pure :: forall (a_0 :: *) . (GHC.Internal.Num.Num a_0, - GHC.Internal.Classes.Eq a_0) => - forall (b_1 :: *) . a_0 -> b_1 -> ([a_0], T8761.Ex) -pattern T8761.Purep :: forall (a_0 :: *) . (GHC.Internal.Num.Num a_0, - GHC.Internal.Classes.Eq a_0) => +pattern T8761.Pu :: forall (a0_0 :: *) . a0_0 -> a0_0 +pattern T8761.Pue :: forall (a0_0 :: *) . () => forall (b_1 :: *) . + a0_0 -> b_1 -> (a0_0, T8761.Ex) +pattern T8761.Pur :: forall (a0_0 :: *) . (GHC.Internal.Num.Num a0_0, + GHC.Internal.Classes.Eq a0_0) => + a0_0 -> [a0_0] +pattern T8761.Purp :: forall (a0_0 :: *) (b0_1 :: *) . (GHC.Internal.Num.Num a0_0, + GHC.Internal.Classes.Eq a0_0) => + GHC.Internal.Show.Show b0_1 => + a0_0 -> b0_1 -> ([a0_0], T8761.UnivProv b0_1) +pattern T8761.Pure :: forall (a0_0 :: *) . (GHC.Internal.Num.Num a0_0, + GHC.Internal.Classes.Eq a0_0) => + forall (b_1 :: *) . a0_0 -> b_1 -> ([a0_0], T8761.Ex) +pattern T8761.Purep :: forall (a0_0 :: *) . (GHC.Internal.Num.Num a0_0, + GHC.Internal.Classes.Eq a0_0) => forall (b_1 :: *) . GHC.Internal.Show.Show b_1 => - a_0 -> b_1 -> ([a_0], T8761.ExProv) + a0_0 -> b_1 -> ([a0_0], T8761.ExProv) pattern T8761.Pep :: () => forall (a_0 :: *) . GHC.Internal.Show.Show a_0 => a_0 -> T8761.ExProv -pattern T8761.Pup :: forall (a_0 :: *) . () => GHC.Internal.Show.Show a_0 => - a_0 -> T8761.UnivProv a_0 -pattern T8761.Puep :: forall (a_0 :: *) . () => forall (b_1 :: *) . GHC.Internal.Show.Show b_1 => - a_0 -> b_1 -> (T8761.ExProv, a_0) +pattern T8761.Pup :: forall (a0_0 :: *) . () => GHC.Internal.Show.Show a0_0 => + a0_0 -> T8761.UnivProv a0_0 +pattern T8761.Puep :: forall (a0_0 :: *) . () => forall (b_1 :: *) . GHC.Internal.Show.Show b_1 => + a0_0 -> b_1 -> (T8761.ExProv, a0_0) T8761.hs:(108,1)-(117,25): Splicing declarations do infos <- mapM reify View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c85c845dc5ad539bf28f1b8c5c1dbb34... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c85c845dc5ad539bf28f1b8c5c1dbb34... You're receiving this email because of your account on gitlab.haskell.org.