[Git][ghc/ghc][wip/T23153] 7 commits: Optimized Foldable methods for Data.Functor.Compose
Krzysztof Gogolewski (@monoidal)
gitlab at gitlab.haskell.org
Thu Mar 23 13:27:55 UTC 2023
Krzysztof Gogolewski pushed to branch wip/T23153 at Glasgow Haskell Compiler / GHC
Commits:
8c98deba by Armando Ramirez at 2023-03-23T09:19:32-04:00
Optimized Foldable methods for Data.Functor.Compose
Explicitly define length, elem, etc. in Foldable instance for Data.Functor.Compose
Implementation of https://github.com/haskell/core-libraries-committee/issues/57
- - - - -
bc066108 by Armando Ramirez at 2023-03-23T09:19:32-04:00
Additional optimized versions
- - - - -
80fce576 by Bodigrim at 2023-03-23T09:19:32-04:00
Simplify minimum/maximum in instance Foldable (Compose f g)
- - - - -
8cb88a5a by Bodigrim at 2023-03-23T09:19:32-04:00
Update changelog to mention changes to instance Foldable (Compose f g)
- - - - -
e1c8c41d by Torsten Schmits at 2023-03-23T09:20:13-04:00
Add structured error messages for GHC.Tc.TyCl.PatSyn
Tracking ticket: #20117
MR: !10158
This converts uses of `mkTcRnUnknownMessage` to newly added constructors
of `TcRnMessage`.
- - - - -
5dc6a9c1 by Krzysztof Gogolewski at 2023-03-23T14:22:44+01:00
Show an error when we cannot default a concrete tyvar
Fixes #23153
- - - - -
9ab9b30e by sheaf at 2023-03-23T14:22:45+01:00
Handle ConcreteTvs in inferResultToType
This patch fixes two issues.
1. 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.
2. startSolvingByUnification can make some type variables concrete.
However, it didn't return an updated type, so callers of this
function, if they don't zonk, might miss this and accidentally
perform a double update of a metavariable.
We now return the updated type from this function, which avoids
this issue.
Fixes #23154
- - - - -
29 changed files:
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Utils/Zonk.hs
- compiler/GHC/Types/Error/Codes.hs
- libraries/base/Data/Functor/Compose.hs
- libraries/base/changelog.md
- testsuite/tests/patsyn/should_fail/T14112.stderr
- testsuite/tests/patsyn/should_fail/T14507.stderr
- testsuite/tests/patsyn/should_fail/unidir.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/PatSynArity.hs
- + testsuite/tests/typecheck/should_fail/PatSynArity.stderr
- + testsuite/tests/typecheck/should_fail/PatSynExistential.hs
- + testsuite/tests/typecheck/should_fail/PatSynExistential.stderr
- + testsuite/tests/typecheck/should_fail/PatSynUnboundVar.hs
- + testsuite/tests/typecheck/should_fail/PatSynUnboundVar.stderr
- testsuite/tests/typecheck/should_fail/VtaFail.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1481,6 +1481,37 @@ instance Diagnostic TcRnMessage where
, text "(Indeed, I sometimes struggle even printing this correctly,"
, text " due to its ill-scoped nature.)"
]
+ TcRnPatSynEscapedCoercion arg bad_co_ne -> mkSimpleDecorated $
+ vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!"
+ , hang (text "Pattern-bound variable")
+ 2 (ppr arg <+> dcolon <+> ppr (idType arg))
+ , nest 2 $
+ hang (text "has a type that mentions pattern-bound coercion"
+ <> plural bad_co_list <> colon)
+ 2 (pprWithCommas ppr bad_co_list)
+ , text "Hint: use -fprint-explicit-coercions to see the coercions"
+ , text "Probable fix: add a pattern signature" ]
+ where
+ bad_co_list = NE.toList bad_co_ne
+ TcRnPatSynExistentialInResult name pat_ty bad_tvs -> mkSimpleDecorated $
+ hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
+ , text "namely" <+> quotes (ppr pat_ty) ])
+ 2 (text "mentions existential type variable" <> plural bad_tvs
+ <+> pprQuotedList bad_tvs)
+ TcRnPatSynArityMismatch name decl_arity missing -> mkSimpleDecorated $
+ hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has"
+ <+> speakNOf decl_arity (text "argument"))
+ 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
+ TcRnPatSynInvalidRhs ps_name lpat args reason -> mkSimpleDecorated $
+ vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
+ <+> quotes (ppr ps_name) <> colon)
+ 2 (pprPatSynInvalidRhsReason ps_name lpat args reason)
+ , text "RHS pattern:" <+> ppr lpat ]
+ TcRnCannotDefaultConcrete frr
+ -> mkSimpleDecorated $
+ ppr (frr_context frr) $$
+ text "cannot be assigned a fixed runtime representation," <+>
+ text "not even by defaulting."
diagnosticReason = \case
TcRnUnknownMessage m
@@ -1965,6 +1996,16 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnSkolemEscape{}
-> ErrorWithoutFlag
+ TcRnPatSynEscapedCoercion{}
+ -> ErrorWithoutFlag
+ TcRnPatSynExistentialInResult{}
+ -> ErrorWithoutFlag
+ TcRnPatSynArityMismatch{}
+ -> ErrorWithoutFlag
+ TcRnPatSynInvalidRhs{}
+ -> ErrorWithoutFlag
+ TcRnCannotDefaultConcrete{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -2467,6 +2508,16 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnSkolemEscape{}
-> noHints
+ TcRnPatSynEscapedCoercion{}
+ -> noHints
+ TcRnPatSynExistentialInResult{}
+ -> noHints
+ TcRnPatSynArityMismatch{}
+ -> noHints
+ TcRnPatSynInvalidRhs{}
+ -> noHints
+ TcRnCannotDefaultConcrete{}
+ -> [SuggestAddTypeSignatures UnnamedBinding]
diagnosticCode = constructorCode
@@ -4561,3 +4612,18 @@ pprUninferrableTyvarCtx = \case
UninfTyCtx_Sig exp_kind full_hs_ty ->
hang (text "the kind" <+> ppr exp_kind) 2
(text "of the type signature:" <+> ppr full_hs_ty)
+
+pprPatSynInvalidRhsReason :: Name -> LPat GhcRn -> [LIdP GhcRn] -> PatSynInvalidRhsReason -> SDoc
+pprPatSynInvalidRhsReason name pat args = \case
+ PatSynNotInvertible p ->
+ text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
+ $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
+ <+> text "pattern synonym, e.g.")
+ 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
+ <+> ppr pat <+> text "where")
+ 2 (pp_name <+> pp_args <+> equals <+> text "..."))
+ where
+ pp_name = ppr name
+ pp_args = hsep (map ppr args)
+ PatSynUnboundVar var ->
+ quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym"
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -95,6 +95,7 @@ module GHC.Tc.Errors.Types (
, WrongThingSort(..)
, StageCheckReason(..)
, UninferrableTyvarCtx(..)
+ , PatSynInvalidRhsReason(..)
) where
import GHC.Prelude
@@ -108,7 +109,7 @@ import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol)
, UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing
, FixedRuntimeRepOrigin(..), InstanceWhat )
import GHC.Tc.Types.Rank (Rank)
-import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType)
+import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType, TcSigmaType)
import GHC.Types.Avail (AvailInfo)
import GHC.Types.Error
import GHC.Types.Hint (UntickedPromotedThing(..))
@@ -118,7 +119,7 @@ import qualified GHC.Types.Name.Occurrence as OccName
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.TyThing (TyThing)
-import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar)
+import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar, CoVar)
import GHC.Types.Var.Env (TidyEnv)
import GHC.Types.Var.Set (TyVarSet, VarSet)
import GHC.Unit.Types (Module)
@@ -3293,6 +3294,62 @@ data TcRnMessage where
-> !Type -- ^ The type in which they occur.
-> TcRnMessage
+ {-| TcRnPatSynEscapedCoercion is an error indicating that a coercion escaped from
+ a pattern synonym into a type.
+ See Note [Coercions that escape] in GHC.Tc.TyCl.PatSyn
+
+ Test cases:
+ T14507
+ -}
+ TcRnPatSynEscapedCoercion :: !Id -- ^ The pattern-bound variable
+ -> !(NE.NonEmpty CoVar) -- ^ The escaped coercions
+ -> TcRnMessage
+
+ {-| TcRnPatSynExistentialInResult is an error indicating that the result type
+ of a pattern synonym mentions an existential type variable.
+
+ Test cases:
+ PatSynExistential
+ -}
+ TcRnPatSynExistentialInResult :: !Name -- ^ The name of the pattern synonym
+ -> !TcSigmaType -- ^ The result type
+ -> ![TyVar] -- ^ The escaped existential variables
+ -> TcRnMessage
+
+ {-| TcRnPatSynArityMismatch is an error indicating that the number of arguments in a
+ pattern synonym's equation differs from the number of parameters in its
+ signature.
+
+ Test cases:
+ PatSynArity
+ -}
+ TcRnPatSynArityMismatch :: !Name -- ^ The name of the pattern synonym
+ -> !Arity -- ^ The number of equation arguments
+ -> !Arity -- ^ The difference
+ -> TcRnMessage
+
+ {-| TcRnPatSynInvalidRhs is an error group indicating that the pattern on the
+ right hand side of a pattern synonym is invalid.
+
+ Test cases:
+ unidir, T14112
+ -}
+ TcRnPatSynInvalidRhs :: !Name -- ^ The name of the pattern synonym
+ -> !(LPat GhcRn) -- ^ The pattern
+ -> ![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
+
deriving Generic
-- | Things forbidden in @type data@ declarations.
@@ -4582,3 +4639,8 @@ data UninferrableTyvarCtx
| UninfTyCtx_TyfamRhs TcType
| UninfTyCtx_TysynRhs TcType
| UninfTyCtx_Sig TcType (LHsSigType GhcRn)
+
+data PatSynInvalidRhsReason
+ = PatSynNotInvertible !(Pat GhcRn)
+ | PatSynUnboundVar !Name
+ deriving (Generic)
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -908,7 +908,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/Equality.hs
=====================================
@@ -1651,7 +1651,7 @@ canEqTyVarFunEq :: CtEvidence -- :: lhs ~ (rhs |> mco)
-> MCoercion -- :: kind(rhs) ~N kind(lhs)
-> TcS (StopOrContinue Ct)
canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco
- = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs
+ = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv1 rhs
; if | case is_touchable of { Untouchable -> False; _ -> True }
, cterHasNoProblem $
checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily
@@ -2440,7 +2440,7 @@ tryToSolveByUnification tv
; dont_unify }
| otherwise
- = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv rhs
+ = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv rhs
; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs
, ppr is_touchable ])
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -1326,35 +1326,37 @@ instance Outputable TouchabilityTestResult where
ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs)
ppr Untouchable = text "Untouchable"
-touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult
--- This is the key test for untouchability:
+touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS (TouchabilityTestResult, TcType)
+-- ^ This is the key test for untouchability:
-- See Note [Unification preconditions] in GHC.Tc.Utils.Unify
-- and Note [Solve by unification] in GHC.Tc.Solver.Interact
+--
+-- Returns a new rhs type, as this function can turn make some metavariables concrete.
touchabilityTest flav tv1 rhs
| flav /= Given -- See Note [Do not unify Givens]
, MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1
- = do { can_continue_solving <- wrapTcS $ startSolvingByUnification info rhs
- ; if not can_continue_solving
- then return Untouchable
- else
- do { ambient_lvl <- getTcLevel
+ = do { continue_solving <- wrapTcS $ startSolvingByUnification info rhs
+ ; case continue_solving of
+ { Nothing -> return (Untouchable, rhs)
+ ; Just rhs ->
+ do { let (free_metas, free_skols) = partition isPromotableMetaTyVar $
+ nonDetEltsUniqSet $
+ tyCoVarsOfType rhs
+ ; ambient_lvl <- getTcLevel
; given_eq_lvl <- getInnermostGivenEqLevel
; if | tv_lvl `sameDepthAs` ambient_lvl
- -> return TouchableSameLevel
+ -> return (TouchableSameLevel, rhs)
| tv_lvl `deeperThanOrSame` given_eq_lvl -- No intervening given equalities
, all (does_not_escape tv_lvl) free_skols -- No skolem escapes
- -> return (TouchableOuterLevel free_metas tv_lvl)
+ -> return (TouchableOuterLevel free_metas tv_lvl, rhs)
| otherwise
- -> return Untouchable } }
+ -> return (Untouchable, rhs) } } }
| otherwise
- = return Untouchable
+ = return (Untouchable, rhs)
where
- (free_metas, free_skols) = partition isPromotableMetaTyVar $
- nonDetEltsUniqSet $
- tyCoVarsOfType rhs
does_not_escape tv_lvl fv
| isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv
@@ -2165,23 +2167,21 @@ breakTyEqCycle_maybe ev cte_result lhs rhs
-- See Detail (8) of the Note.
= do { should_break <- final_check
- ; if should_break then do { redn <- go rhs
- ; return (Just redn) }
- else return Nothing }
+ ; mapM go should_break }
where
flavour = ctEvFlavour ev
eq_rel = ctEvEqRel ev
final_check = case flavour of
- Given -> return True
+ Given -> return $ Just rhs
Wanted -- Wanteds work only with a touchable tyvar on the left
-- See "Wanted" section of the Note.
| TyVarLHS lhs_tv <- lhs ->
- do { result <- touchabilityTest Wanted lhs_tv rhs
+ do { (result, rhs) <- touchabilityTest Wanted lhs_tv rhs
; return $ case result of
- Untouchable -> False
- _ -> True }
- | otherwise -> return False
+ Untouchable -> Nothing
+ _ -> Just rhs }
+ | otherwise -> return Nothing
-- This could be considerably more efficient. See Detail (5) of Note.
go :: TcType -> TcS ReductionN
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -41,7 +41,6 @@ import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
import GHC.Core.Predicate
import GHC.Builtin.Types.Prim
-import GHC.Types.Error
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
@@ -68,6 +67,7 @@ import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors )
import Data.Maybe( mapMaybe )
import Control.Monad ( zipWithM )
import Data.List( partition, mapAccumL )
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
{-
************************************************************************
@@ -185,10 +185,11 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
-- Report coercions that escape
-- See Note [Coercions that escape]
; args <- mapM zonkId args
- ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts
- , let bad_cos = filterDVarSet isId $
- (tyCoVarsOfTypeDSet (idType arg))
- , not (isEmptyDVarSet bad_cos) ]
+ ; let bad_arg arg = fmap (\bad_cos -> (arg, bad_cos)) $
+ nonEmpty $
+ dVarSetElems $
+ filterDVarSet isId (tyCoVarsOfTypeDSet (idType arg))
+ bad_args = mapMaybe bad_arg (args ++ prov_dicts)
; mapM_ dependentArgErr bad_args
-- Report un-quantifiable type variables:
@@ -236,22 +237,11 @@ mkProvEvidence ev_id
pred = evVarPred ev_id
eq_con_args = [evId ev_id]
-dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
+dependentArgErr :: (Id, NonEmpty CoVar) -> TcM ()
-- See Note [Coercions that escape]
dependentArgErr (arg, bad_cos)
= failWithTc $ -- fail here: otherwise we get downstream errors
- mkTcRnUnknownMessage $ mkPlainError noHints $
- vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!"
- , hang (text "Pattern-bound variable")
- 2 (ppr arg <+> dcolon <+> ppr (idType arg))
- , nest 2 $
- hang (text "has a type that mentions pattern-bound coercion"
- <> plural bad_co_list <> colon)
- 2 (pprWithCommas ppr bad_co_list)
- , text "Hint: use -fprint-explicit-coercions to see the coercions"
- , text "Probable fix: add a pattern signature" ]
- where
- bad_co_list = dVarSetElems bad_cos
+ TcRnPatSynEscapedCoercion arg bad_cos
{- Note [Type variables whose kind is captured]
~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -405,11 +395,7 @@ tcCheckPatSynDecl psb at PSB{ psb_id = lname@(L _ name), psb_args = details
-- The existential 'x' should not appear in the result type
-- Can't check this until we know P's arity (decl_arity above)
; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs
- ; checkTc (null bad_tvs) $ mkTcRnUnknownMessage $ mkPlainError noHints $
- hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
- , text "namely" <+> quotes (ppr pat_ty) ])
- 2 (text "mentions existential type variable" <> plural bad_tvs
- <+> pprQuotedList bad_tvs)
+ ; checkTc (null bad_tvs) $ TcRnPatSynExistentialInResult name pat_ty bad_tvs
-- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig
; let univ_fvs = closeOverKinds $
@@ -679,10 +665,7 @@ collectPatSynArgInfo details =
wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
wrongNumberOfParmsErr name decl_arity missing
- = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
- hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has"
- <+> speakNOf decl_arity (text "argument"))
- 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
+ = failWithTc $ TcRnPatSynArityMismatch name decl_arity missing
-------------------------
-- Shared by both tcInferPatSyn and tcCheckPatSyn
@@ -921,11 +904,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
= return emptyBag
| Left why <- mb_match_group -- Can't invert the pattern
- = setSrcSpan (getLocA lpat) $ failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
- vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
- <+> quotes (ppr ps_name) <> colon)
- 2 why
- , text "RHS pattern:" <+> ppr lpat ]
+ = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnPatSynInvalidRhs ps_name lpat args why
| Right match_group <- mb_match_group -- Bidirectional
= do { patsyn <- tcLookupPatSyn ps_name
@@ -975,7 +954,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
mb_match_group
= case dir of
ExplicitBidirectional explicit_mg -> Right explicit_mg
- ImplicitBidirectional -> fmap mk_mg (tcPatToExpr ps_name args lpat)
+ ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat)
Unidirectional -> panic "tcPatSynBuilderBind"
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
@@ -1019,8 +998,8 @@ add_void need_dummy_arg ty
| need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty
| otherwise = ty
-tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn
- -> Either SDoc (LHsExpr GhcRn)
+tcPatToExpr :: [LocatedN Name] -> LPat GhcRn
+ -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
-- Given a /pattern/, return an /expression/ that builds a value
-- that matches the pattern. E.g. if the pattern is (Just [x]),
-- the expression is (Just [x]). They look the same, but the
@@ -1029,13 +1008,13 @@ tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn
--
-- Returns (Left r) if the pattern is not invertible, for reason r.
-- See Note [Builder for a bidirectional pattern synonym]
-tcPatToExpr name args pat = go pat
+tcPatToExpr args pat = go pat
where
lhsVars = mkNameSet (map unLoc args)
-- Make a prefix con for prefix and infix patterns for simplicity
mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn]
- -> Either SDoc (HsExpr GhcRn)
+ -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkPrefixConExpr lcon@(L loc _) pats
= do { exprs <- mapM go pats
; let con = L (l2l loc) (HsVar noExtField lcon)
@@ -1043,18 +1022,18 @@ tcPatToExpr name args pat = go pat
}
mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn)
- -> Either SDoc (HsExpr GhcRn)
+ -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkRecordConExpr con (HsRecFields fields dd)
= do { exprFields <- mapM go' fields
; return (RecordCon noExtField con (HsRecFields exprFields dd)) }
- go' :: LHsRecField GhcRn (LPat GhcRn) -> Either SDoc (LHsRecField GhcRn (LHsExpr GhcRn))
+ go' :: LHsRecField GhcRn (LPat GhcRn) -> Either PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn))
go' (L l rf) = L l <$> traverse go rf
- go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
+ go :: LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
go (L loc p) = L loc <$> go1 p
- go1 :: Pat GhcRn -> Either SDoc (HsExpr GhcRn)
+ go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 (ConPat NoExtField con info)
= case info of
PrefixCon _ ps -> mkPrefixConExpr con ps
@@ -1068,7 +1047,7 @@ tcPatToExpr name args pat = go pat
| var `elemNameSet` lhsVars
= return $ HsVar noExtField (L l var)
| otherwise
- = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
+ = Left (PatSynUnboundVar var)
go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat
go1 (ListPat _ pats)
= do { exprs <- mapM go pats
@@ -1105,19 +1084,7 @@ tcPatToExpr name args pat = go pat
go1 p@(AsPat {}) = notInvertible p
go1 p@(NPlusKPat {}) = notInvertible p
- notInvertible p = Left (not_invertible_msg p)
-
- not_invertible_msg p
- = text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
- $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
- <+> text "pattern synonym, e.g.")
- 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
- <+> ppr pat <+> text "where")
- 2 (pp_name <+> pp_args <+> equals <+> text "..."))
- where
- pp_name = ppr name
- pp_args = hsep (map ppr args)
-
+ notInvertible p = Left (PatSynNotInvertible p)
{- Note [Builder for a bidirectional pattern synonym]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -480,7 +481,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
@@ -536,20 +546,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 <- newConcreteTyVarAtLevel conc_orig tc_lvl runtimeRepTy
+ ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)
+ ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr
+ ; return tau }
{- Note [inferResultToType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -872,6 +890,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) $
@@ -917,7 +942,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
@@ -935,7 +960,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
@@ -1100,6 +1125,13 @@ newMetaTyVarTyAtLevel tc_lvl kind
; name <- newMetaTyVarName (fsLit "p")
; return (mkTyVarTy (mkTcTyVar name kind details)) }
+newConcreteTyVarAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType
+newConcreteTyVarAtLevel conc_orig tc_lvl kind
+ = do { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl
+ ; name <- newMetaTyVarName (fsLit "c")
+ ; return (mkTyVarTy (mkTcTyVar name kind details)) }
+
+
{- *********************************************************************
* *
Finding variables to quantify over
@@ -2235,7 +2267,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
@@ -2253,7 +2285,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/Unify.hs
=====================================
@@ -2072,10 +2072,10 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2
-- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles
, cterHasNoProblem (checkTyVarEq tv1 ty2)
-- See Note [Prevent unification with type families]
- = do { can_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2
- ; if not can_continue_solving
- then not_ok_so_defer
- else
+ = do { mb_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2
+ ; case mb_continue_solving of
+ { Nothing -> not_ok_so_defer
+ ; Just ty2 ->
do { co_k <- uType KindLevel kind_origin (typeKind ty2) (tyVarKind tv1)
; traceTc "uUnfilledVar2 ok" $
vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)
@@ -2089,9 +2089,9 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2
then do { writeMetaTyVar tv1 ty2
; return (mkNomReflCo ty2) }
- else defer }} -- This cannot be solved now. See GHC.Tc.Solver.Canonical
- -- Note [Equalities with incompatible kinds] for how
- -- this will be dealt with in the solver
+ else defer }}} -- This cannot be solved now. See GHC.Tc.Solver.Canonical
+ -- Note [Equalities with incompatible kinds] for how
+ -- this will be dealt with in the solver
| otherwise
= not_ok_so_defer
@@ -2111,39 +2111,38 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2
-- | Checks (TYVAR-TV), (COERCION-HOLE) and (CONCRETE) of
-- Note [Unification preconditions]; returns True if these conditions
-- are satisfied. But see the Note for other preconditions, too.
-startSolvingByUnification :: MetaInfo -> TcType -- zonked
- -> TcM Bool
+startSolvingByUnification :: MetaInfo -> TcType -- zonked
+ -> TcM (Maybe TcType)
startSolvingByUnification _ xi
| hasCoercionHoleTy xi -- (COERCION-HOLE) check
- = return False
+ = return Nothing
startSolvingByUnification info xi
= case info of
- CycleBreakerTv -> return False
+ CycleBreakerTv -> return Nothing
ConcreteTv conc_orig ->
- do { (_, not_conc_reasons) <- makeTypeConcrete conc_orig xi
+ do { (xi, not_conc_reasons) <- makeTypeConcrete conc_orig xi
-- NB: makeTypeConcrete has the side-effect of turning
-- some TauTvs into ConcreteTvs, e.g.
-- alpha[conc] ~# TYPE (TupleRep '[ beta[tau], IntRep ])
-- will write `beta[tau] := beta[conc]`.
--
- -- We don't need to track these unifications for the purposes
- -- of constraint solving (e.g. updating tcs_unified or tcs_unif_lvl),
- -- as they don't unlock any further progress.
+ -- We return the new type, so that callers of this function
+ -- aren't required to zonk.
; case not_conc_reasons of
- [] -> return True
- _ -> return False }
+ [] -> return $ Just xi
+ _ -> return Nothing }
TyVarTv ->
case getTyVar_maybe xi of
- Nothing -> return False
+ Nothing -> return Nothing
Just tv ->
case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle
- SkolemTv {} -> return True
- RuntimeUnk -> return True
+ SkolemTv {} -> return $ Just xi
+ RuntimeUnk -> return $ Just xi
MetaTv { mtv_info = info } ->
case info of
- TyVarTv -> return True
- _ -> return False
- _ -> return True
+ TyVarTv -> return $ Just xi
+ _ -> return Nothing
+ _ -> return $ Just xi
swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool
swapOverTyVars is_given tv1 tv2
=====================================
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
=====================================
@@ -542,6 +542,12 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnCannotDefaultKindVar" = 79924
GhcDiagnosticCode "TcRnUninferrableTyvar" = 16220
GhcDiagnosticCode "TcRnSkolemEscape" = 71451
+ GhcDiagnosticCode "TcRnPatSynEscapedCoercion" = 88986
+ GhcDiagnosticCode "TcRnPatSynExistentialInResult" = 33973
+ GhcDiagnosticCode "TcRnPatSynArityMismatch" = 18365
+ GhcDiagnosticCode "PatSynNotInvertible" = 69317
+ GhcDiagnosticCode "PatSynUnboundVar" = 28572
+ GhcDiagnosticCode "TcRnCannotDefaultConcrete" = 52083
-- IllegalNewtypeReason
GhcDiagnosticCode "DoesNotHaveSingleField" = 23517
@@ -711,6 +717,7 @@ type family ConRecursInto con where
ConRecursInto "TcRnNotInScope" = 'Just NotInScopeError
ConRecursInto "TcRnIllegalNewtype" = 'Just IllegalNewtypeReason
ConRecursInto "TcRnHsigShapeMismatch" = 'Just HsigShapeMismatchReason
+ ConRecursInto "TcRnPatSynInvalidRhs" = 'Just PatSynInvalidRhsReason
--
-- TH errors
=====================================
libraries/base/Data/Functor/Compose.hs
=====================================
@@ -31,6 +31,8 @@ import Data.Functor.Classes
import Control.Applicative
import Data.Coerce (coerce)
import Data.Data (Data)
+import Data.Foldable (Foldable(..))
+import Data.Monoid (Sum(..), All(..), Any(..), Product(..))
import Data.Type.Equality (TestEquality(..), (:~:)(..))
import GHC.Generics (Generic, Generic1)
import Text.Read (Read(..), ReadPrec, readListDefault, readListPrecDefault)
@@ -111,7 +113,23 @@ instance (Functor f, Functor g) => Functor (Compose f g) where
-- | @since 4.9.0.0
instance (Foldable f, Foldable g) => Foldable (Compose f g) where
+ fold (Compose t) = foldMap fold t
foldMap f (Compose t) = foldMap (foldMap f) t
+ foldMap' f (Compose t) = foldMap' (foldMap' f) t
+ foldr f b (Compose fga) = foldr (\ga acc -> foldr f acc ga) b fga
+ foldr' f b (Compose fga) = foldr' (\ga acc -> foldr' f acc ga) b fga
+ foldl f b (Compose fga) = foldl (\acc ga -> foldl f acc ga) b fga
+ foldl' f b (Compose fga) = foldl' (\acc ga -> foldl' f acc ga) b fga
+
+ null (Compose t) = null t || getAll (foldMap (All . null) t)
+ length (Compose t) = getSum (foldMap' (Sum . length) t)
+ elem x (Compose t) = getAny (foldMap (Any . elem x) t)
+
+ minimum (Compose fga) = minimum $ map minimum $ filter (not . null) $ toList fga
+ maximum (Compose fga) = maximum $ map maximum $ filter (not . null) $ toList fga
+
+ sum (Compose t) = getSum (foldMap' (Sum . sum) t)
+ product (Compose t) = getProduct (foldMap' (Product . product) t)
-- | @since 4.9.0.0
instance (Traversable f, Traversable g) => Traversable (Compose f g) where
=====================================
libraries/base/changelog.md
=====================================
@@ -12,6 +12,8 @@
* Add `Type.Reflection.decTypeRep`, `Data.Typeable.decT` and `Data.Typeable.hdecT` equality decisions functions.
([CLC proposal #98](https://github.com/haskell/core-libraries-committee/issues/98))
* Add `Data.Functor.unzip` ([CLC proposal #88](https://github.com/haskell/core-libraries-committee/issues/88))
+ * Implement more members of `instance Foldable (Compose f g)` explicitly.
+ ([CLC proposal #57](https://github.com/haskell/core-libraries-committee/issues/57))
## 4.18.0.0 *TBA*
=====================================
testsuite/tests/patsyn/should_fail/T14112.stderr
=====================================
@@ -1,5 +1,5 @@
-T14112.hs:5:21: error:
+T14112.hs:5:21: error: [GHC-69317]
Invalid right-hand side of bidirectional pattern synonym ‘MyJust1’:
Pattern ‘!a’ is not invertible
Suggestion: instead use an explicitly bidirectional pattern synonym, e.g.
=====================================
testsuite/tests/patsyn/should_fail/T14507.stderr
=====================================
@@ -1,5 +1,5 @@
-T14507.hs:21:1: error:
+T14507.hs:21:1: error: [GHC-88986]
• Iceland Jack! Iceland Jack! Stop torturing me!
Pattern-bound variable x :: TypeRep a
has a type that mentions pattern-bound coercion: co
=====================================
testsuite/tests/patsyn/should_fail/unidir.stderr
=====================================
@@ -1,5 +1,5 @@
-unidir.hs:4:18: error:
+unidir.hs:4:18: error: [GHC-69317]
Invalid right-hand side of bidirectional pattern synonym ‘Head’:
Pattern ‘_’ is not invertible
Suggestion: instead use an explicitly bidirectional pattern synonym, e.g.
=====================================
testsuite/tests/rep-poly/RepPolyPatBind.stderr
=====================================
@@ -17,3 +17,36 @@ RepPolyPatBind.hs:18:5: error: [GHC-55287]
x, y :: a
(# x, y #) = undefined
in x
+
+RepPolyPatBind.hs:18:8: error: [GHC-55287]
+ • The pattern binding does not have a fixed runtime representation.
+ Its type is:
+ (# a0, b0 #) :: TYPE (TupleRep [k00, k10])
+ Cannot unify ‘rep’ with the type variable ‘k00’
+ 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:11: error: [GHC-55287]
+ • The pattern binding does not have a fixed runtime representation.
+ Its type is:
+ (# a0, b0 #) :: TYPE (TupleRep [k00, k10])
+ Cannot unify ‘rep’ with the type variable ‘k10’
+ 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
+ x :: a (bound at RepPolyPatBind.hs:18:8)
+ foo :: () -> a (bound at RepPolyPatBind.hs:15:1)
=====================================
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,15 @@
+
+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.
+
+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/PatSynArity.hs
=====================================
@@ -0,0 +1,6 @@
+{-# language PatternSynonyms #-}
+
+module PatSynArity where
+
+pattern P :: Int -> (Int, Int)
+pattern P a b = (a, b)
=====================================
testsuite/tests/typecheck/should_fail/PatSynArity.stderr
=====================================
@@ -0,0 +1,4 @@
+PatSynArity.hs:6:1: [GHC-18365]
+ Pattern synonym ‘P’ has two arguments
+ but its type signature has 1 fewer arrows
+ In the declaration for pattern synonym ‘P’
=====================================
testsuite/tests/typecheck/should_fail/PatSynExistential.hs
=====================================
@@ -0,0 +1,6 @@
+{-# language PatternSynonyms #-}
+
+module PatSynExistential where
+
+pattern P :: () => forall x. x -> Maybe x
+pattern P <- _
=====================================
testsuite/tests/typecheck/should_fail/PatSynExistential.stderr
=====================================
@@ -0,0 +1,4 @@
+PatSynExistential.hs:6:1: [GHC-33973]
+ The result type of the signature for ‘P’, namely ‘x -> Maybe x’
+ mentions existential type variable ‘x’
+ In the declaration for pattern synonym ‘P’
=====================================
testsuite/tests/typecheck/should_fail/PatSynUnboundVar.hs
=====================================
@@ -0,0 +1,6 @@
+{-# language PatternSynonyms #-}
+
+module PatSynUnboundVar where
+
+pattern P :: Int -> (Int, Int)
+pattern P a = (a, b)
=====================================
testsuite/tests/typecheck/should_fail/PatSynUnboundVar.stderr
=====================================
@@ -0,0 +1,4 @@
+PatSynUnboundVar.hs:6:15: [GHC-28572]
+ Invalid right-hand side of bidirectional pattern synonym ‘P’:
+ ‘b’ is not bound by the LHS of the pattern synonym
+ RHS pattern: (a, b)
=====================================
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’:
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -672,3 +672,6 @@ test('T22924a', normal, compile_fail, [''])
test('T22924b', normal, compile_fail, [''])
test('T22940', normal, compile_fail, [''])
test('T19627', normal, compile_fail, [''])
+test('PatSynExistential', normal, compile_fail, [''])
+test('PatSynArity', normal, compile_fail, [''])
+test('PatSynUnboundVar', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/307ca52badaa72fba06a3f4db006c5204f5b3035...9ab9b30ec1affe22b188f9a6637ac3bdea75bdba
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/307ca52badaa72fba06a3f4db006c5204f5b3035...9ab9b30ec1affe22b188f9a6637ac3bdea75bdba
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/20230323/52739726/attachment-0001.html>
More information about the ghc-commits
mailing list