[Git][ghc/ghc][wip/expand-do] 8 commits: Optimized Foldable methods for Data.Functor.Compose
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Thu Mar 23 19:00:56 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do 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`.
- - - - -
59be8f3e by Apoorv Ingle at 2023-03-23T14:00:22-05:00
HsExpand for HsDo
Fixes for #18324
- fixed rec do blocks to use mfix
- make sure fail is used for pattern match failures in bind statments
- - - - -
ca100ab6 by Apoorv Ingle at 2023-03-23T14:00:22-05:00
move expand_do_stmts GHC.Tc.Match so that we can type check patterns and determine more accurately if we need to generate a fail block
- - - - -
849c014b by Apoorv Ingle at 2023-03-23T14:00:22-05:00
do stmt expansion for Applicative Do
- - - - -
25 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl/PatSyn.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/rebindable/T18324.hs
- + testsuite/tests/rebindable/T23147.hs
- testsuite/tests/rebindable/all.T
- + testsuite/tests/rebindable/pattern-fails.hs
- + 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/all.T
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -418,6 +418,23 @@ type instance XXExpr GhcTc = XXExprGhcTc
-- HsExpansion: see Note [Rebindable syntax and HsExpansion] below
+
+{- *********************************************************************
+* *
+ Generating code for HsExpanded
+ See Note [Handling overloaded and rebindable constructs]
+* *
+********************************************************************* -}
+
+-- | Build a 'HsExpansion' out of an extension constructor,
+-- and the two components of the expansion: original and
+-- desugared expressions.
+mkExpandedExpr
+ :: HsExpr GhcRn -- ^ source expression
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
+mkExpandedExpr a b = XExpr (HsExpanded a b)
+
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
{-# UNPACK #-} !(HsWrap HsExpr)
@@ -1055,11 +1072,12 @@ data HsExpansion orig expanded
= HsExpanded orig expanded
deriving Data
--- | Just print the original expression (the @a@).
+-- | Just print the original expression (the @a@) with the expanded version (the @b@)
instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
ppr (HsExpanded orig expanded)
- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
- (ppr orig)
+ -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
+ -- (ppr orig)
+ = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
{-
@@ -1961,6 +1979,13 @@ matchDoContextErrString (MDoExpr m) = prependQualified m (text "'mdo' block")
matchDoContextErrString ListComp = text "list comprehension"
matchDoContextErrString MonadComp = text "monad comprehension"
+instance Outputable HsDoFlavour where
+ ppr (DoExpr m) = text "DoExpr" <+> parens (ppr m)
+ ppr (MDoExpr m) = text "MDoExpr" <+> parens (ppr m)
+ ppr GhciStmtCtxt = text "GhciStmtCtxt"
+ ppr ListComp = text "ListComp"
+ ppr MonadComp = text "MonadComp"
+
pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)
=> Match (GhcPass idR) body -> SDoc
pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -24,7 +24,7 @@ free variables.
-}
module GHC.Rename.Expr (
- rnLExpr, rnExpr, rnStmts, mkExpandedExpr,
+ rnLExpr, rnExpr, rnStmts,
AnnoBody, UnexpectedStatement(..)
) where
@@ -433,8 +433,8 @@ rnExpr (HsDo _ do_or_lc (L l stmts))
rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts
(\ _ -> return ((), emptyFVs))
; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
- ; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) }
-
+ ; return (HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2)
+ }
-- ExplicitList: see Note [Handling overloaded and rebindable constructs]
rnExpr (ExplicitList _ exps)
= do { (exps', fvs) <- rnExprs exps
@@ -1071,8 +1071,10 @@ postProcessStmtsForApplicativeDo ctxt stmts
; in_th_bracket <- isBrackStage <$> getStage
; if ado_is_on && is_do_expr && not in_th_bracket
then do { traceRn "ppsfa" (ppr stmts)
- ; rearrangeForApplicativeDo ctxt stmts }
- else noPostProcessStmts (HsDoStmt ctxt) stmts }
+ ; ado_stmts_and_fvs <- rearrangeForApplicativeDo ctxt stmts
+ ; return ado_stmts_and_fvs }
+ else do { do_stmts_and_fvs <- noPostProcessStmts (HsDoStmt ctxt) stmts
+ ; return do_stmts_and_fvs } }
-- | strip the FreeVars annotations from statements
noPostProcessStmts
@@ -1165,7 +1167,7 @@ rnStmt ctxt rnBody (L loc (LastStmt _ (L lb body) noret _)) thing_inside
else return (noSyntaxExpr, emptyFVs)
-- The 'return' in a LastStmt is used only
-- for MonadComp; and we don't want to report
- -- "non in scope: return" in other cases
+ -- "not in scope: return" in other cases
-- #15607
; (thing, fvs3) <- thing_inside []
@@ -1811,7 +1813,7 @@ independent and do something like this:
(y,z) <- (,) <$> B x <*> C
return (f x y z)
-But this isn't enough! A and C were also independent, and this
+But this isn't enough! If A and C were also independent, then this
transformation loses the ability to do A and C in parallel.
The algorithm works by first splitting the sequence of statements into
@@ -2694,14 +2696,6 @@ getMonadFailOp ctxt
* *
********************************************************************* -}
--- | Build a 'HsExpansion' out of an extension constructor,
--- and the two components of the expansion: original and
--- desugared expressions.
-mkExpandedExpr
- :: HsExpr GhcRn -- ^ source expression
- -> HsExpr GhcRn -- ^ expanded expression
- -> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
-mkExpandedExpr a b = XExpr (HsExpanded a b)
-----------------------------------------
-- Bits and pieces for RecordDotSyntax.
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1481,6 +1481,32 @@ 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 ]
diagnosticReason = \case
TcRnUnknownMessage m
@@ -1965,6 +1991,14 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnSkolemEscape{}
-> ErrorWithoutFlag
+ TcRnPatSynEscapedCoercion{}
+ -> ErrorWithoutFlag
+ TcRnPatSynExistentialInResult{}
+ -> ErrorWithoutFlag
+ TcRnPatSynArityMismatch{}
+ -> ErrorWithoutFlag
+ TcRnPatSynInvalidRhs{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -2467,6 +2501,14 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnSkolemEscape{}
-> noHints
+ TcRnPatSynEscapedCoercion{}
+ -> noHints
+ TcRnPatSynExistentialInResult{}
+ -> noHints
+ TcRnPatSynArityMismatch{}
+ -> noHints
+ TcRnPatSynInvalidRhs{}
+ -> noHints
diagnosticCode = constructorCode
@@ -4561,3 +4603,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,52 @@ 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
+
deriving Generic
-- | Things forbidden in @type data@ declarations.
@@ -4582,3 +4629,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/Expr.hs
=====================================
@@ -49,7 +49,6 @@ import GHC.Tc.Gen.Head
import GHC.Tc.Gen.Bind ( tcLocalBinds )
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )
import GHC.Core.FamInstEnv ( FamInstEnvs )
-import GHC.Rename.Expr ( mkExpandedExpr )
import GHC.Rename.Env ( addUsedGRE )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -42,7 +42,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC
, tcCheckMonoExpr, tcCheckMonoExprNC
, tcCheckPolyExpr )
-import GHC.Rename.Utils ( bindLocalNames )
+import GHC.Rename.Utils ( bindLocalNames, genHsApp, genHsApps, genHsVar )
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
@@ -66,21 +66,24 @@ import GHC.Hs
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
+import GHC.Builtin.Names (bindMName, returnMName)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
-import GHC.Driver.Session ( getDynFlags )
+import GHC.Driver.Session ( getDynFlags, DynFlags )
+import GHC.Driver.Ppr (showPpr)
import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.SrcLoc
+import GHC.Types.Basic (Origin (..))
import Control.Monad
import Control.Arrow ( second )
import qualified Data.List.NonEmpty as NE
-
+import Data.List ((\\))
{-
************************************************************************
* *
@@ -316,14 +319,29 @@ tcDoStmts ListComp (L l stmts) res_ty
; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
- = do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
- ; res_ty <- readExpType res_ty
- ; return (HsDo res_ty doExpr (L l stmts')) }
+ = do { -- stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
+ -- ; res_ty <- readExpType res_ty
+ -- ; return (HsDo res_ty doExpr (L l stmts'))
+ expand_expr <- expand_do_stmts doExpr stmts
+ ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doExpr (L l stmts))
+ (unLoc expand_expr)
+ -- Do expansion on the fly
+ ; traceTc "tcDoStmts" (text "tcExpr:" <+> ppr expand_do_expr)
+ ; tcExpr expand_do_expr res_ty
+ }
tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty
- = do { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
- ; res_ty <- readExpType res_ty
- ; return (HsDo res_ty mDoExpr (L l stmts')) }
+ = do { -- stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
+ -- ; res_ty <- readExpType res_ty
+ -- ; return (HsDo res_ty mDoExpr (L l stmts'))
+ expand_expr <- expand_do_stmts mDoExpr stmts
+ ; let expand_do_expr = mkExpandedExpr (HsDo noExtField mDoExpr (L l stmts))
+ (unLoc expand_expr)
+ -- Do expansion on the fly
+ ; traceTc "tcDoStmts" (text "tcExpr:" <+> ppr expand_do_expr)
+ ; tcExpr expand_do_expr res_ty
+
+ }
tcDoStmts MonadComp (L l stmts) res_ty
= do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
@@ -857,7 +875,7 @@ tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
= do { body' <- tcMonoExprNC body res_ty
; thing <- thing_inside (panic "tcDoStmt: thing_inside")
; return (LastStmt x body' noret noSyntaxExpr, thing) }
-
+-- ANI TODO: This is really needed?
tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
= do { -- Deal with rebindable syntax:
-- (>>=) :: rhs_ty ->_rhs_mult (pat_ty ->_pat_mult new_res_ty) ->_fun_mult res_ty
@@ -896,7 +914,7 @@ tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
\ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty))
; return (ApplicativeStmt body_ty pairs' mb_join', thing) }
-
+-- ANI TODO: can we get rid of this?
tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
= do { -- Deal with rebindable syntax;
-- (>>) :: rhs_ty -> new_res_ty -> res_ty
@@ -909,7 +927,7 @@ tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 1) rhs_ty
; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 2) new_res_ty
; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }
-
+-- ANI TODO: Is this really needed?
tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
, recS_rec_ids = rec_names, recS_ret_fn = ret_op
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
@@ -1172,3 +1190,207 @@ checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
args_in_match :: (LocatedA (Match GhcRn body1) -> Int)
args_in_match (L _ (Match { m_pats = pats })) = length pats
+
+{-
+************************************************************************
+* *
+\subsection{HsExpansion for Do Statements}
+* *
+************************************************************************
+-}
+-- | Expand the Do statments so that it works fine with Quicklook
+-- See Note[Rebindable Do and Expanding Statements]
+-- ANI Questions: 1. What should be the location information in the expanded expression? Currently the error is displayed on the expanded expr and not on the unexpanded expr
+expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+
+expand_do_stmts do_flavour [L _ (LastStmt _ body _ ret_expr)]
+ -- last statement of a list comprehension, needs to explicitly return it
+ -- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
+ -- TODO: i don't think we need this if we never call from a ListComp
+ | ListComp <- do_flavour
+ = return $ noLocA (genHsApp (genHsVar returnMName) body)
+ | NoSyntaxExprRn <- ret_expr
+ -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
+ = return body
+ | SyntaxExprRn ret <- ret_expr
+ --
+ -- ------------------------------------------------
+ -- return e ~~> return e
+ -- to make T18324 work
+ = return $ mkHsApp (noLocA ret) body
+
+
+expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
+ | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
+ , fail_op <- xbsrn_failOp xbsrn =
+-- the pattern binding x can fail
+-- stmts ~~> stmt' let f pat = stmts'; f _ = fail ".."
+-- -------------------------------------------------------
+-- pat <- e ; stmts ~~> (Prelude.>>=) e f
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
+ return $ noLocA (foldl genHsApp bind_op -- (>>=)
+ [ e
+ , expr
+ ])
+
+ | otherwise = -- just use the polymorhpic bindop. TODO: Necessary?
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ return $ noLocA (genHsApps bindMName -- (Prelude.>>=)
+ [ e
+ , mkHsLam [pat] expand_stmts -- (\ x -> stmts')
+ ])
+
+expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) =
+-- stmts ~~> stmts'
+-- ------------------------------------------------
+-- let x = e ; stmts ~~> let x = e in stmts'
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ return $ noLocA (HsLet noExtField noHsTok bnds noHsTok (expand_stmts))
+
+
+expand_do_stmts do_or_lc ((L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
+-- See Note [BodyStmt]
+-- stmts ~~> stmts'
+-- ----------------------------------------------
+-- e ; stmts ~~> (>>) e stmts'
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ return $ mkHsApps (noLocA f) -- (>>)
+ [ e -- e
+ , expand_stmts ] -- stmts'
+
+expand_do_stmts do_or_lc
+ ((L _ (RecStmt { recS_stmts = rec_stmts
+ , recS_later_ids = later_ids -- forward referenced local ids
+ , recS_rec_ids = local_ids -- ids referenced outside of the rec block
+ , recS_mfix_fn = SyntaxExprRn mfix_fun -- the `mfix` expr
+ , recS_ret_fn = SyntaxExprRn return_fun -- the `return` expr
+ -- use it explicitly
+ -- at the end of expanded rec block
+ }))
+ : lstmts) =
+-- See Note [Typing a RecStmt]
+-- stmts ~~> stmts'
+-- -------------------------------------------------------------------------------------------
+-- rec { later_ids, local_ids, rec_block } ; stmts
+-- ~~> (>>=) (mfix (\[ local_only_ids ++ later_ids ]
+-- -> do { rec_stmts
+-- ; return (local_only_ids ++ later_ids) } ))
+-- (\ [ local_only_ids ++ later_ids ] -> stmts')
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ return $ noLocA (genHsApps bindMName -- (Prelude.>>=)
+ [ (noLocA mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
+ , mkHsLam [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
+ expand_stmts -- stmts')
+ ])
+ where
+ local_only_ids = local_ids \\ later_ids -- get unique local rec ids;
+ --local rec ids and later ids can overlap
+ all_ids = local_only_ids ++ later_ids -- put local ids before return ids
+
+ return_stmt :: ExprLStmt GhcRn
+ return_stmt = noLocA $ LastStmt noExtField
+ (mkHsApp (noLocA return_fun)
+ $ mkBigLHsTup (map nlHsVar all_ids) noExtField)
+ Nothing
+ (SyntaxExprRn return_fun)
+ do_stmts :: XRec GhcRn [ExprLStmt GhcRn]
+ do_stmts = noLocA $ (unLoc rec_stmts) ++ [return_stmt]
+ do_block :: LHsExpr GhcRn
+ do_block = noLocA $ HsDo noExtField (DoExpr Nothing) $ do_stmts
+ mfix_expr :: LHsExpr GhcRn
+ mfix_expr = mkHsLam [ mkBigLHsVarPatTup all_ids ] $ do_block
+
+expand_do_stmts do_or_lc (stmt@(L _ (ApplicativeStmt _ args mb_join)): lstmts) =
+-- See Note [Applicative BodyStmt]
+--
+-- stmts ~~> stmts'
+-- -------------------------------------------------
+-- ; stmts ~~> (\ x -> stmts') <$> e1 <*> e2 ...
+--
+-- Very similar to HsToCore.Expr.dsDo
+
+-- args are [(<$>, e1), (<*>, e2), .., ]
+-- mb_join is Maybe (join)
+ do { expr' <- expand_do_stmts do_or_lc lstmts
+ ; (pats_can_fail, rhss) <- unzip <$> mapM (do_arg . snd) args
+
+ ; body <- foldrM match_args expr' pats_can_fail -- add blocks for failable patterns
+
+ ; let expand_ado_expr = foldl mk_app_call body (zip (map fst args) rhss)
+ ; traceTc "expand_do_stmts: debug" $ (vcat [ text "stmt:" <+> ppr stmt
+ , text "(pats,rhss):" <+> ppr (pats_can_fail, rhss)
+ , text "expr':" <+> ppr expr'
+ , text "args" <+> ppr args
+ , text "final_ado" <+> ppr expand_ado_expr
+ ])
+
+
+ -- pprPanic "expand_do_stmts: impossible happened ApplicativeStmt" empty
+ ; case mb_join of
+ Nothing -> return expand_ado_expr
+ Just NoSyntaxExprRn -> return expand_ado_expr -- this is stupid
+ Just (SyntaxExprRn join_op) -> return $ mkHsApp (noLocA join_op) expand_ado_expr
+ }
+ where
+ do_arg :: ApplicativeArg GhcRn -> TcM ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)
+ do_arg (ApplicativeArgOne mb_fail_op pat expr _) =
+ return ((pat, mb_fail_op), expr)
+ do_arg (ApplicativeArgMany _ stmts ret pat _) =
+ do { expr <- expand_do_stmts do_or_lc $ stmts ++ [noLocA $ mkLastStmt (noLocA ret)]
+ ; return ((pat, Nothing), expr) }
+
+ match_args :: (LPat GhcRn, FailOperator GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
+ match_args (pat, fail_op) body = mk_failable_lexpr_tcm pat body fail_op
+
+ mk_app_call l (op, r) = case op of
+ SyntaxExprRn op -> mkHsApps (noLocA op) [l, r]
+ NoSyntaxExprRn -> pprPanic "expand_do_stmts: impossible happened first arg" (ppr op)
+
+expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) =
+ pprPanic "expand_do_stmts: impossible happened TransStmt" $ ppr stmt
+
+expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
+-- See See Note [Monad Comprehensions]
+
+ pprPanic "expand_do_stmts: impossible happened ParStmt" $ ppr stmt
+
+
+expand_do_stmts do_flavor stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr do_flavor $$ ppr stmts)
+
+
+
+mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
+-- checks the pattern pat and decides if we need to plug in the fail block
+-- Type checking the pattern is necessary to decide if we need to generate the fail block
+-- Renamer cannot always determine if a fail block is necessary, and its conservative behaviour would
+-- generate a fail block even if it is not really needed. cf. GHC.Hs.isIrrefutableHsPat
+-- Only Tuples are considered irrefutable in the renamer, while newtypes and TyCons with only one datacon
+-- is not
+mk_failable_lexpr_tcm pat lexpr fail_op =
+ do { ((tc_pat, _), _) <- tcInferPat (FRRBindStmt DoNotation)
+ PatBindRhs pat $ return id -- whatever
+ ; dflags <- getDynFlags
+ ; if isIrrefutableHsPat dflags tc_pat
+ then return $ mkHsLam [pat] lexpr
+ else mk_fail_lexpr pat lexpr fail_op
+ }
+
+-- makes the fail block
+-- TODO: check the discussion around MonadFail.fail type signature.
+-- Should we really say `mkHsString "fail pattern"`? if yes, maybe a better error message would help
+mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
+mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
+ do dflags <- getDynFlags
+ return $ noLocA (HsLam noExtField $ mkMatchGroup Generated -- let
+ (noLocA [ mkHsCaseAlt pat lexpr -- f pat = expr
+ , mkHsCaseAlt nlWildPatName -- f _ = fail "fail pattern"
+ (noLocA $ genHsApp fail_op
+ (mk_fail_msg_expr dflags (DoExpr Nothing) pat))
+ ]))
+mk_fail_lexpr _ _ _ = pprPanic "mk_fail_lexpr: impossible happened" empty
+
+mk_fail_msg_expr :: DynFlags -> HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn
+mk_fail_msg_expr dflags ctx pat
+ = nlHsLit $ mkHsString $ showPpr dflags $ text "Pattern match failure in" <+> pprHsDoFlavour ctx
+ <+> text "at" <+> ppr (getLocA pat)
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -104,7 +104,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
-----------------
tcPats :: HsMatchContext GhcTc
- -> [LPat GhcRn] -- ^ atterns
+ -> [LPat GhcRn] -- ^ patterns
-> [Scaled ExpSigmaTypeFRR] -- ^ types of the patterns
-> TcM a -- ^ checker for the body
-> TcM ([LPat GhcTc], a)
=====================================
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/Types/Error/Codes.hs
=====================================
@@ -542,6 +542,11 @@ 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
-- IllegalNewtypeReason
GhcDiagnosticCode "DoesNotHaveSingleField" = 23517
@@ -711,6 +716,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/rebindable/T18324.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE ImpredicativeTypes, DeriveAnyClass #-}
+-- {-# LANGUAGE MonadComprehensions, RecursiveDo #-}
+module Main where
+
+
+type Id = forall a. a -> a
+
+t :: IO Id
+t = return id
+
+p :: Id -> (Bool, Int)
+p f = (f True, f 3)
+
+foo1 = t >>= \x -> return (p x)
+
+foo2 = do { x <- t ; return (p x) }
+
+
+main = do x <- foo2
+ putStrLn $ show x
+
=====================================
testsuite/tests/rebindable/T23147.hs
=====================================
@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE QualifiedDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE GADTs #-}
+
+module T23147 where
+
+import qualified Control.Monad as M
+import Prelude hiding (return, (>>=))
+
+type Exis f = (forall r. (forall t. f t -> r) -> r)
+
+data Indexed t where
+ Indexed :: Indexed Int
+
+(>>=) :: Monad m => m (Exis f) -> (forall t. f t -> m (Exis g)) -> m (Exis g)
+x >>= f = x M.>>= (\x' -> x' f)
+
+return :: Monad m => Exis f -> m (Exis f)
+return = M.return
+
+test :: (Monad m) => Exis Indexed -> m (Exis Indexed)
+test x =
+ T23147.do
+ (reified :: Indexed t) <- return x
+ return (\g -> g reified)
=====================================
testsuite/tests/rebindable/all.T
=====================================
@@ -42,3 +42,7 @@ test('T14670', expect_broken(14670), compile, [''])
test('T19167', normal, compile, [''])
test('T19918', normal, compile_and_run, [''])
test('T20126', normal, compile_fail, [''])
+# Tests for desugaring do before typechecking
+test('T18324', normal, compile, [''])
+test('T23147', normal, compile, [''])
+test('pattern-fails', normal, compile, [''])
=====================================
testsuite/tests/rebindable/pattern-fails.hs
=====================================
@@ -0,0 +1,18 @@
+module PF where
+
+
+-- main :: IO ()
+-- main = putStrLn . show $ qqq ['c']
+
+qqq :: [a] -> Maybe (a, [a])
+qqq ts = do { (a:b:as) <- Just ts
+ ; return (a, as) }
+
+newtype ST a b = ST (a, b)
+
+emptyST :: Maybe (ST Int Int)
+emptyST = Just $ ST (0, 0)
+
+ppp :: Maybe (ST Int Int) -> Maybe (ST Int Int)
+ppp st = do { ST (x, y) <- st
+ ; return $ ST (x+1, y+1)}
=====================================
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/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/2e96c807f77dd16775f34d18fa7800215504a908...849c014be1e38dfa569aab2436b531b68cc0952f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2e96c807f77dd16775f34d18fa7800215504a908...849c014be1e38dfa569aab2436b531b68cc0952f
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/c73fbafa/attachment-0001.html>
More information about the ghc-commits
mailing list