diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index b00c493e7d198d8b379cf17c57d3ea65d451c4d2..e65df0c53df6f7fe0282d3c5f4ced672fb675a2d 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -460,17 +460,104 @@ tupArgsPresent_maybe = traverse tupArgPresent_maybe
********************************************************************* -}
type instance XXExpr GhcPs = DataConCantHappen
-type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) (HsExpr GhcRn)
+type instance XXExpr GhcRn = XXExprGhcRn
type instance XXExpr GhcTc = XXExprGhcTc
--- HsExpansion: see Note [Rebindable syntax and HsExpansion] below
+-- XXExprGhcRn: see Note [Rebindable syntax and XXExprGhcRn] below
+
+
+{- *********************************************************************
+* *
+ Generating code for ExpandedThingRn
+ See Note [Handling overloaded and rebindable constructs]
+* *
+********************************************************************* -}
+
+-- | The different source constructs that we use to instantiate the "original" field
+-- in an `XXExprGhcRn original expansion`
+data HsThingRn = OrigExpr (HsExpr GhcRn)
+ | OrigStmt (ExprLStmt GhcRn)
+ | OrigPat (LPat GhcRn)
+
+isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool
+isHsThingRnExpr (OrigExpr{}) = True
+isHsThingRnExpr _ = False
+
+isHsThingRnStmt (OrigStmt{}) = True
+isHsThingRnStmt _ = False
+
+isHsThingRnPat (OrigPat{}) = True
+isHsThingRnPat _ = False
+
+data XXExprGhcRn
+ = ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing
+ , xrn_expanded :: HsExpr GhcRn } -- The compiler generated expanded thing
+
+ | PopErrCtxt -- A hint for typechecker to pop
+ {-# UNPACK #-} !(LHsExpr GhcRn) -- the top of the error context stack
+ -- Does not presist post renaming phase
+ -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]
+ -- in `GHC.Tc.Gen.Do`
+
+
+-- | Wrap a located expression with a `PopErrCtxt`
+mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn
+mkPopErrCtxtExpr a = XExpr (PopErrCtxt a)
+
+-- | Wrap a located expression with a PopSrcExpr with an appropriate location
+mkPopErrCtxtExprAt :: SrcSpanAnnA -> LHsExpr GhcRn -> LHsExpr GhcRn
+mkPopErrCtxtExprAt loc a = L loc $ mkPopErrCtxtExpr a
+
+-- | Build an expression using the extension constructor `XExpr`,
+-- and the two components of the expansion: original expression and
+-- expanded expressions.
+mkExpandedExpr
+ :: HsExpr GhcRn -- ^ source expression
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr)
+
+-- | Build an expression using the extension constructor `XExpr`,
+-- and the two components of the expansion: original do stmt and
+-- expanded expression
+mkExpandedStmt
+ :: ExprLStmt GhcRn -- ^ source statement
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr)
+
+mkExpandedPatRn
+ :: LPat GhcRn -- ^ source pattern
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr)
+
+-- | Build an expression using the extension constructor `XExpr`,
+-- and the two components of the expansion: original do stmt and
+-- expanded expression an associate with a provided location
+mkExpandedStmtAt
+ :: SrcSpanAnnA -- ^ Location for the expansion expression
+ -> ExprLStmt GhcRn -- ^ source statement
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn'
+mkExpandedStmtAt loc oStmt eExpr = L loc $ mkExpandedStmt oStmt eExpr
+
+-- | Wrap the expanded version of the expression with a pop.
+mkExpandedStmtPopAt
+ :: SrcSpanAnnA -- ^ Location for the expansion statement
+ -> ExprLStmt GhcRn -- ^ source statement
+ -> HsExpr GhcRn -- ^ expanded expression
+ -> LHsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt eExpr
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
{-# UNPACK #-} !(HsWrap HsExpr)
- | ExpansionExpr -- See Note [Rebindable syntax and HsExpansion] below
- {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))
+ | ExpandedThingTc -- See Note [Rebindable syntax and XXExprGhcRn]
+ -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
+ { xtc_orig :: HsThingRn -- The original user written thing
+ , xtc_expanded :: HsExpr GhcTc } -- The expanded typechecked expression
| ConLikeTc -- Result of typechecking a data-con
-- See Note [Typechecking data constructors] in
@@ -491,6 +578,23 @@ data XXExprGhcTc
Int -- module-local tick number for False
(LHsExpr GhcTc) -- sub-expression
+-- | Build a 'XXExprGhcRn' out of an extension constructor,
+-- and the two components of the expansion: original and
+-- expanded typechecked expressions.
+mkExpandedExprTc
+ :: HsExpr GhcRn -- ^ source expression
+ -> HsExpr GhcTc -- ^ expanded typechecked expression
+ -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr)
+
+-- | Build a 'XXExprGhcRn' out of an extension constructor.
+-- The two components of the expansion are: original statement and
+-- expanded typechecked expression.
+mkExpandedStmtTc
+ :: ExprLStmt GhcRn -- ^ source do statement
+ -> HsExpr GhcTc -- ^ expanded typechecked expression
+ -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedStmtTc oStmt eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt) eExpr)
{- *********************************************************************
* *
@@ -727,14 +831,28 @@ ppr_expr (XExpr x) = case ghcPass @p of
GhcRn -> ppr x
GhcTc -> ppr x
+instance Outputable HsThingRn where
+ ppr thing
+ = case thing of
+ OrigExpr x -> ppr_builder "<OrigExpr>:" x
+ OrigStmt x -> ppr_builder "<OrigStmt>:" x
+ OrigPat x -> ppr_builder "<OrigPat>:" x
+ where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)
+
+instance Outputable XXExprGhcRn where
+ ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)
+ ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)
+
instance Outputable XXExprGhcTc where
ppr (WrapExpr (HsWrap co_fn e))
= pprHsWrapper co_fn (\_parens -> pprExpr e)
- ppr (ExpansionExpr e)
- = ppr e -- e is an HsExpansion, we print the original
- -- expression (LHsExpr GhcPs), not the
- -- desugared one (LHsExpr GhcTc).
+ ppr (ExpandedThingTc o e)
+ = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)
+ -- e is the expanded expression, we print the original
+ -- expression (HsExpr GhcRn), not the
+ -- expanded typechecked one (HsExpr GhcTc),
+ -- unless we are in ppr's debug mode printed both
ppr (ConLikeTc con _ _) = pprPrefixOcc con
-- Used in error messages generated by
@@ -762,15 +880,20 @@ ppr_infix_expr (XExpr x) = case ghcPass @p of
GhcTc -> ppr_infix_expr_tc x
ppr_infix_expr _ = Nothing
-ppr_infix_expr_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Maybe SDoc
-ppr_infix_expr_rn (HsExpanded a _) = ppr_infix_expr a
+ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
+ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing
+ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
-ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e
-ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a
-ppr_infix_expr_tc (ConLikeTc {}) = Nothing
-ppr_infix_expr_tc (HsTick {}) = Nothing
-ppr_infix_expr_tc (HsBinTick {}) = Nothing
+ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e
+ppr_infix_expr_tc (ExpandedThingTc thing _) = ppr_infix_hs_expansion thing
+ppr_infix_expr_tc (ConLikeTc {}) = Nothing
+ppr_infix_expr_tc (HsTick {}) = Nothing
+ppr_infix_expr_tc (HsBinTick {}) = Nothing
+
+ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc
+ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e
+ppr_infix_hs_expansion _ = Nothing
ppr_apps :: (OutputableBndrId p)
=> HsExpr (GhcPass p)
@@ -788,7 +911,6 @@ ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))
pp (Right arg)
= text "@" <> ppr arg
-
pprDebugParendExpr :: (OutputableBndrId p)
=> PprPrec -> LHsExpr (GhcPass p) -> SDoc
pprDebugParendExpr p expr
@@ -864,14 +986,18 @@ hsExprNeedsParens prec = go
go_x_tc :: XXExprGhcTc -> Bool
go_x_tc (WrapExpr (HsWrap _ e)) = hsExprNeedsParens prec e
- go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a
+ go_x_tc (ExpandedThingTc thing _) = hsExpandedNeedsParens thing
go_x_tc (ConLikeTc {}) = False
go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e
go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
- go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool
- go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a
+ go_x_rn :: XXExprGhcRn -> Bool
+ go_x_rn (ExpandedThingRn thing _) = hsExpandedNeedsParens thing
+ go_x_rn (PopErrCtxt (L _ a)) = hsExprNeedsParens prec a
+ hsExpandedNeedsParens :: HsThingRn -> Bool
+ hsExpandedNeedsParens (OrigExpr e) = hsExprNeedsParens prec e
+ hsExpandedNeedsParens _ = False
-- | Parenthesize an expression without token information
gHsPar :: forall p. IsPass p => LHsExpr (GhcPass p) -> HsExpr (GhcPass p)
@@ -912,13 +1038,18 @@ isAtomicHsExpr (XExpr x)
where
go_x_tc :: XXExprGhcTc -> Bool
go_x_tc (WrapExpr (HsWrap _ e)) = isAtomicHsExpr e
- go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a
+ go_x_tc (ExpandedThingTc thing _) = isAtomicExpandedThingRn thing
go_x_tc (ConLikeTc {}) = True
go_x_tc (HsTick {}) = False
go_x_tc (HsBinTick {}) = False
- go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool
- go_x_rn (HsExpanded a _) = isAtomicHsExpr a
+ go_x_rn :: XXExprGhcRn -> Bool
+ go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing
+ go_x_rn (PopErrCtxt (L _ a)) = isAtomicHsExpr a
+
+ isAtomicExpandedThingRn :: HsThingRn -> Bool
+ isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e
+ isAtomicExpandedThingRn _ = False
isAtomicHsExpr _ = False
@@ -932,11 +1063,11 @@ instance Outputable (HsPragE (GhcPass p)) where
{- *********************************************************************
* *
- HsExpansion and rebindable syntax
+ XXExprGhcRn and rebindable syntax
* *
********************************************************************* -}
-{- Note [Rebindable syntax and HsExpansion]
+{- Note [Rebindable syntax and XXExprGhcRn]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We implement rebindable syntax (RS) support by performing a desugaring
in the renamer. We transform GhcPs expressions and patterns affected by
@@ -970,12 +1101,12 @@ To remedy this, instead of transforming the original HsIf
node into mere applications of 'ifThenElse', we keep the
original 'if' expression around too, using the TTG
XExpr extension point to allow GHC to construct an
-'HsExpansion' value that will keep track of the original
+'XXExprGhcRn' value that will keep track of the original
expression in its first field, and the desugared one in the
second field. The resulting renamed AST would look like:
L locif (XExpr
- (HsExpanded
+ (ExpandedThingRn
(HsIf (L loca 'a')
(L loctrue ())
(L locfalse True)
@@ -997,7 +1128,7 @@ second field. The resulting renamed AST would look like:
When comes the time to typecheck the program, we end up calling
tcMonoExpr on the AST above. If this expression gives rise to
a type error, then it will appear in a context line and GHC
-will pretty-print it using the 'Outputable (HsExpansion a b)'
+will pretty-print it using the 'Outputable (XXExprGhcRn a b)'
instance defined below, which *only prints the original
expression*. This is the gist of the idea, but is not quite
enough to recover the error messages that we had with the
@@ -1048,12 +1179,12 @@ A general recipe to follow this approach for new constructs could go as follows:
HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'
- take both the original node and that rebound-and-renamed result and wrap
them into an expansion construct:
- for expressions, XExpr (HsExpanded <original node> <desugared>)
+ for expressions, XExpr (ExpandedThingRn <original node> <desugared>)
for patterns, XPat (HsPatExpanded <original node> <desugared>)
- At typechecking-time:
- remove any logic that was previously dealing with your rebindable
construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.
- - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we
+ - the XExpr (ExpandedThingRn ... ...) case in tcExpr already makes sure that we
typecheck the desugared expression while reporting the original one in
errors
-}
@@ -1066,16 +1197,16 @@ syntax.
The language extensions @OverloadedRecordDot@ and
@OverloadedRecordUpdate@ (providing "record dot syntax") are
implemented using the techniques of Note [Rebindable syntax and
-HsExpansion].
+XXExprGhcRn].
When OverloadedRecordDot is enabled:
- Field selection expressions
- e.g. foo.bar.baz
- Have abstract syntax HsGetField
- - After renaming are XExpr (HsExpanded (HsGetField ...) (getField @"..."...)) expressions
+ - After renaming are XExpr (ExpandedThingRn (HsGetField ...) (getField @"..."...)) expressions
- Field selector expressions e.g. (.x.y)
- Have abstract syntax HsProjection
- - After renaming are XExpr (HsExpanded (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions
+ - After renaming are XExpr (ExpandedThingRn (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions
When OverloadedRecordUpdate is enabled:
- Record update expressions
@@ -1083,7 +1214,7 @@ When OverloadedRecordUpdate is enabled:
- Have abstract syntax RecordUpd
- With rupd_flds containting a Right
- See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr)
- - After renaming are XExpr (HsExpanded (RecordUpd ...) (setField@"..." ...) expressions
+ - After renaming are XExpr (ExpandedThingRn (RecordUpd ...) (setField@"..." ...) expressions
- Note that this is true for all record updates even for those that do not involve '.'
When OverloadedRecordDot is enabled and RebindableSyntax is not
@@ -1099,17 +1230,6 @@ OverloadedRecordUpd is enabled and RebindableSyntax is enabled the
names 'getField' and 'setField' are whatever in-scope names they are.
-}
--- See Note [Rebindable syntax and HsExpansion] just above.
-data HsExpansion orig expanded
- = HsExpanded orig expanded
- deriving Data
-
--- | Just print the original expression (the @a@).
-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)
-
{-
************************************************************************
@@ -1330,7 +1450,7 @@ instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where
-}
type instance XMG GhcPs b = Origin
-type instance XMG GhcRn b = Origin
+type instance XMG GhcRn b = Origin -- See Note [Generated code and pattern-match checking]
type instance XMG GhcTc b = MatchGroupTc
data MatchGroupTc
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index edbff6064fe868914dd6a56a3d9a2a5c74add118..b06b64e3de56dfb6777d49c41d481e36326b5a60 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -388,8 +388,6 @@ deriving instance Data (HsStmtContext GhcTc)
deriving instance Data HsArrowMatchContext
-deriving instance Data HsDoFlavour
-
deriving instance Data (HsMatchContext GhcPs)
deriving instance Data (HsMatchContext GhcRn)
deriving instance Data (HsMatchContext GhcTc)
@@ -564,6 +562,8 @@ deriving instance Eq (IE GhcTc)
-- ---------------------------------------------------------------------
+deriving instance Data HsThingRn
+deriving instance Data XXExprGhcRn
deriving instance Data XXExprGhcTc
deriving instance Data XXPatGhcTc
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index b7f01d8d1dc5143ff7758372e6ce45e142a1f54e..5d0e90a5ef69798425ca2357321ee56948abd56d 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -40,11 +40,11 @@ module GHC.Hs.Pat (
mkPrefixConPat, mkCharLitPat, mkNilPat,
- isSimplePat,
+ isSimplePat, isPatSyn,
looksLazyPatBind,
isBangedLPat,
gParPat, patNeedsParens, parenthesizePat,
- isIrrefutableHsPat, isBoringHsPat,
+ isIrrefutableHsPatHelper, isIrrefutableHsPatHelperM, isBoringHsPat,
collectEvVarsPat, collectEvVarsPats,
@@ -85,6 +85,7 @@ import GHC.Data.Maybe
import GHC.Types.Name (Name, dataName)
import Data.Data
+import Data.Functor.Identity
type instance XWildPat GhcPs = NoExtField
type instance XWildPat GhcRn = NoExtField
@@ -165,10 +166,10 @@ type instance XEmbTyPat GhcTc = Type
type instance XXPat GhcPs = DataConCantHappen
type instance XXPat GhcRn = HsPatExpansion (Pat GhcRn) (Pat GhcRn)
-- Original pattern and its desugaring/expansion.
- -- See Note [Rebindable syntax and HsExpansion].
+ -- See Note [Rebindable syntax and XXExprGhcRn].
type instance XXPat GhcTc = XXPatGhcTc
- -- After typechecking, we add extra constructors: CoPat and HsExpansion.
- -- HsExpansion allows us to handle RebindableSyntax in pattern position:
+ -- After typechecking, we add extra constructors: CoPat and XXExprGhcRn.
+ -- XXExprGhcRn allows us to handle RebindableSyntax in pattern position:
-- see "XXExpr GhcTc" for the counterpart in expressions.
type instance ConLikeP GhcPs = RdrName -- IdP GhcPs
@@ -216,11 +217,11 @@ data XXPatGhcTc
}
-- | Pattern expansion: original pattern, and desugared pattern,
-- for RebindableSyntax and other overloaded syntax such as OverloadedLists.
- -- See Note [Rebindable syntax and HsExpansion].
+ -- See Note [Rebindable syntax and XXExprGhcRn].
| ExpansionPat (Pat GhcRn) (Pat GhcTc)
--- See Note [Rebindable syntax and HsExpansion].
+-- See Note [Rebindable syntax and XXExprGhcRn].
data HsPatExpansion a b
= HsPatExpanded a b
deriving Data
@@ -295,7 +296,7 @@ instance (Outputable p, OutputableBndr p, Outputable arg)
instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
ppr = pprPat
--- See Note [Rebindable syntax and HsExpansion].
+-- See Note [Rebindable syntax and XXExprGhcRn].
instance (Outputable a, Outputable b) => Outputable (HsPatExpansion a b) where
ppr (HsPatExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)
@@ -512,7 +513,6 @@ looksLazyPat (VarPat {}) = False
looksLazyPat (WildPat {}) = False
looksLazyPat _ = True
-
{-
Note [-XStrict and irrefutability]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -538,6 +538,21 @@ encounters a LazyPat and -XStrict is enabled.
See also Note [decideBangHood] in GHC.HsToCore.Utils.
-}
+
+type ConLikePIrrefutableCheck m p
+ = Bool -- ^ Are we in a @-XStrict@ context?
+ -- See Note [-XStrict and irrefutability]
+ -> XRec p (ConLikeP p) -- ^ ConLikeThing
+ -> HsConPatDetails p -- ^ ConPattern details
+ -> m Bool -- ^ is it Irrefutable?
+
+type LPatIrrefutableCheck m p
+ = Bool -- ^ Are we in a @-XStrict@ context?
+ -- See Note [-XStrict and irrefutability]
+ -> ConLikePIrrefutableCheck m p -- How should I check ConLikeP things
+ -> LPat p -- The LPat thing
+ -> m Bool -- Is it irrefutable?
+
-- | (isIrrefutableHsPat p) is true if matching against p cannot fail
-- in the sense of falling through to the next pattern.
-- (NB: this is not quite the same as the (silly) defn
@@ -550,54 +565,69 @@ See also Note [decideBangHood] in GHC.HsToCore.Utils.
-- tuple patterns are considered irrefutable at the renamer stage.
--
-- But if it returns True, the pattern is definitely irrefutable
-isIrrefutableHsPat :: forall p. (OutputableBndrId p)
- => Bool -- ^ Are we in a @-XStrict@ context?
- -- See Note [-XStrict and irrefutability]
- -> LPat (GhcPass p) -> Bool
-isIrrefutableHsPat is_strict = goL
+-- Instantiates `isIrrefutableHsPatHelperM` with a trivial identity monad
+isIrrefutableHsPatHelper :: forall p. (OutputableBndrId p)
+ => Bool -- ^ Are we in a @-XStrict@ context?
+ -- See Note [-XStrict and irrefutability]
+ -> LPat (GhcPass p) -> Bool
+isIrrefutableHsPatHelper is_strict pat = runIdentity $ doWork is_strict pat
where
- goL :: LPat (GhcPass p) -> Bool
- goL = go . unLoc
+ doWork :: forall p. (OutputableBndrId p) => Bool -> LPat (GhcPass p) -> Identity Bool
+ doWork is_strict = isIrrefutableHsPatHelperM is_strict isConLikeIrr
+
+ isConLikeIrr :: forall p. (OutputableBndrId p) => ConLikePIrrefutableCheck Identity (GhcPass p)
+ isConLikeIrr is_strict con details
+ = case ghcPass @p of
+ GhcPs -> return False -- Conservative
+ GhcRn -> return False -- Conservative
+ GhcTc -> case con of
+ L _ (PatSynCon _pat) -> return False -- Conservative
+ L _ (RealDataCon con) ->
+ do let b = isJust (tyConSingleDataCon_maybe (dataConTyCon con))
+ bs <- mapM (doWork is_strict) (hsConPatArgs details)
+ return $ b && and bs
+
+
+-- This function abstracts 2 things
+-- 1. How to compute irrefutability for a `ConLikeP` thing
+-- 2. The wrapper monad
+isIrrefutableHsPatHelperM :: forall m p. (Monad m, OutputableBndrId p)
+ => LPatIrrefutableCheck m (GhcPass p)
+isIrrefutableHsPatHelperM is_strict isConLikeIrr pat = go (unLoc pat)
+ where
+ goL = isIrrefutableHsPatHelperM is_strict isConLikeIrr
- go :: Pat (GhcPass p) -> Bool
- go (WildPat {}) = True
- go (VarPat {}) = True
+ go :: Pat (GhcPass p) -> m Bool
+ go (WildPat {}) = return True
+ go (VarPat {}) = return True
go (LazyPat _ p')
| is_strict
- = isIrrefutableHsPat False p'
- | otherwise = True
+ = isIrrefutableHsPatHelperM False isConLikeIrr p'
+ | otherwise = return True
go (BangPat _ pat) = goL pat
go (ParPat _ pat) = goL pat
go (AsPat _ _ pat) = goL pat
go (ViewPat _ _ pat) = goL pat
go (SigPat _ pat _) = goL pat
- go (TuplePat _ pats _) = all goL pats
- go (SumPat {}) = False
+ go (TuplePat _ pats _) = do { bs <- mapM goL pats; return $ and bs }
+ go (SumPat {}) = return False
-- See Note [Unboxed sum patterns aren't irrefutable]
- go (ListPat {}) = False
+ go (ListPat {}) = return False
go (ConPat
{ pat_con = con
- , pat_args = details })
- = case ghcPass @p of
- GhcPs -> False -- Conservative
- GhcRn -> False -- Conservative
- GhcTc -> case con of
- L _ (PatSynCon _pat) -> False -- Conservative
- L _ (RealDataCon con) ->
- isJust (tyConSingleDataCon_maybe (dataConTyCon con))
- && all goL (hsConPatArgs details)
- go (LitPat {}) = False
- go (NPat {}) = False
- go (NPlusKPat {}) = False
+ , pat_args = details }) = isConLikeIrr is_strict con details
+ go (LitPat {}) = return False
+ go (NPat {}) = return False
+ go (NPlusKPat {}) = return False
-- We conservatively assume that no TH splices are irrefutable
-- since we cannot know until the splice is evaluated.
- go (SplicePat {}) = False
+ go (SplicePat {}) = return False
-- The behavior of this case is unimportant, as GHC will throw an error shortly
-- after reaching this case for other reasons (see TcRnIllegalTypePattern).
- go (EmbTyPat {}) = True
+ go (EmbTyPat {}) = return True
go (XPat ext) = case ghcPass @p of
GhcRn -> case ext of
@@ -623,7 +653,7 @@ isSimplePat p = case unLoc p of
_ -> Nothing
-- | Is this pattern boring from the perspective of pattern-match checking,
--- i.e. introduces no new pieces of long-dinstance information
+-- i.e. introduces no new pieces of long-distance information
-- which could influence pattern-match checking?
--
-- See Note [Boring patterns].
@@ -673,6 +703,10 @@ isBoringHsPat = goL
CoPat _ pat _ -> go pat
ExpansionPat _ pat -> go pat
+isPatSyn :: LPat GhcTc -> Bool
+isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True
+isPatSyn _ = False
+
{- Note [Unboxed sum patterns aren't irrefutable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 497632e2e3fd8b441e170846279648ddb77856f3..d51f30a4075812b89dbd89301f563cb790a08e18 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -144,7 +144,7 @@ hsExprType (HsStatic (_, ty) _s) = ty
hsExprType (HsPragE _ _ e) = lhsExprType e
hsExprType (HsEmbTy x _) = dataConCantHappen x
hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e
-hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e
+hsExprType (XExpr (ExpandedThingTc _ e)) = hsExprType e
hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con
hsExprType (XExpr (HsTick _ e)) = lhsExprType e
hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 761de4af306482264c25d69a328c00411c54a902..49b6c4decdb1691f5f541f9c745ee9031b855243 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -275,7 +275,7 @@ mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
-> LHsExpr (GhcPass p)
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noAnn LamSingle matches))
where
- matches = mkMatchGroup (Generated SkipPmc)
+ matches = mkMatchGroup (Generated OtherExpansion SkipPmc)
(noLocA [mkSimpleMatch (LamAlt LamSingle) pats' body])
pats' = map (parenthesizePat appPrec) pats
@@ -611,7 +611,8 @@ nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
-- AZ:Is this used?
nlHsLam match = noLocA $ HsLam noAnn LamSingle
- $ mkMatchGroup (Generated SkipPmc) (noLocA [match])
+ $ mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [match])
+
nlHsPar e = noLocA (gHsPar e)
-- nlHsIf should generate if-expressions which are NOT subject to
@@ -620,8 +621,8 @@ nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf cond true false = noLocA (HsIf noAnn cond true false)
nlHsCase expr matches
- = noLocA (HsCase noAnn expr (mkMatchGroup (Generated SkipPmc) (noLocA matches)))
-nlList exprs = noLocA (ExplicitList noAnn exprs)
+ = noLocA (HsCase noAnn expr (mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA matches)))
+nlList exprs = noLocA (ExplicitList noAnn exprs)
nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar :: IsSrcSpanAnn p a
@@ -892,7 +893,7 @@ spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
-> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind loc fun pats expr
- = L (noAnnSrcSpan loc) $ mkFunBind (Generated SkipPmc) (L (noAnnSrcSpan loc) fun)
+ = L (noAnnSrcSpan loc) $ mkFunBind (Generated OtherExpansion SkipPmc) (L (noAnnSrcSpan loc) fun)
[mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr
emptyLocalBinds]
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 370bbe9afbbe74cac5e5ea1283873e89568cb923..37c8678f9cdfe63a7c91b82b0aa4bffa47d99b6a 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -810,7 +810,7 @@ dsCases ids local_vars stack_id stack_ty res_ty
Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$>
dsExpr (HsLam noAnn LamCase
(MG { mg_alts = noLocA []
- , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated SkipPmc)
+ , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated OtherExpansion SkipPmc)
}))
-- Replace the commands in the case with these tagged tuples,
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 70f6252325b5daf60052d5d513defe9101a353f1..a0c21155284831ab90db51a04ec85aec07ade868 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -314,7 +314,10 @@ dsExpr (HsOverLit _ lit)
dsExpr e@(XExpr ext_expr_tc)
= case ext_expr_tc of
- ExpansionExpr (HsExpanded _ b) -> dsExpr b
+ ExpandedThingTc o e
+ | OrigStmt (L loc _) <- o
+ -> putSrcSpanDsA loc $ dsExpr e
+ | otherwise -> dsExpr e
WrapExpr {} -> dsHsWrapped e
ConLikeTc con tvs tys -> dsConLike con tvs tys
-- Hpc Support
@@ -370,6 +373,7 @@ dsExpr e@(HsApp _ fun arg)
; addMessagesDs msgs'
; pmcRecSel fun_id arg' }
_ -> addMessagesDs msgs
+ ; warnUnusedBindValue fun arg (exprType arg')
; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }
where
is_incomplete_rec_sel_msg :: MsgEnvelope DsMessage -> Bool
@@ -828,7 +832,7 @@ dsDo ctx stmts
later_pats = rec_tup_pats
rets = map noLocA rec_rets
mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
- match_group = MatchGroupTc [unrestricted tup_ty] body_ty (Generated SkipPmc)
+ match_group = MatchGroupTc [unrestricted tup_ty] body_ty (Generated OtherExpansion SkipPmc)
mfix_arg = noLocA $ HsLam noAnn LamSingle
(MG { mg_alts = noLocA [mkSimpleMatch
(LamAlt LamSingle)
@@ -943,6 +947,28 @@ dsConLike con tvs tys
************************************************************************
-}
+-- Warn about certain types of values discarded in monadic bindings (#3263)
+warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
+warnUnusedBindValue fun arg@(L loc _) arg_ty
+ | Just (l, f) <- fish_var fun
+ , f `hasKey` thenMClassOpKey -- it is a (>>)
+ = when (isGeneratedSrcSpan l) $ -- it is compiler generated (>>)
+ putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty
+ where
+ -- Retrieve the location info and the head of the application
+ -- It is important that we /do not/ look through HsApp to avoid
+ -- generating duplicate warnings
+ -- See Part 2. of Note [Expanding HsDo with XXExprGhcRn]
+ fish_var :: LHsExpr GhcTc -> Maybe (SrcSpan , Id)
+ fish_var (L l (HsVar _ id)) = return (locA l, unLoc id)
+ fish_var (L _ (HsAppType _ e _)) = fish_var e
+ fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e)
+ return (l, e')
+ fish_var (L l (XExpr (ExpandedThingTc _ e))) = fish_var (L l e)
+ fish_var _ = Nothing
+
+warnUnusedBindValue _ _ _ = return ()
+
-- Warn about certain types of values discarded in monadic bindings (#3263)
warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
warnDiscardedDoBindings rhs rhs_ty
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index b930583a9ad6c3135bf6b2b8b4a82e2543d40d75..a0905f5559cc11cc5d7f6f4da2d6b2bfe23299f5 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -29,7 +29,8 @@ import Language.Haskell.Syntax.Basic (Boxity(..))
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
-import GHC.Types.Basic ( Origin(..), requiresPMC )
+import GHC.Types.Basic ( Origin(..), requiresPMC, isDoExpansionGenerated )
+
import GHC.Types.SourceText
( FractionalLit,
IntegralLit(il_value),
@@ -41,6 +42,7 @@ import GHC.Hs.Syn.Type
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.HsToCore.Pmc
+import GHC.HsToCore.Pmc.Utils
import GHC.HsToCore.Pmc.Types ( Nablas )
import GHC.HsToCore.Monad
import GHC.HsToCore.Binds
@@ -763,12 +765,20 @@ one pattern, and match simply only accepts one pattern.
JJQC 30-Nov-1997
-}
-matchWrapper ctxt scrs (MG { mg_alts = L _ matches
+matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
, mg_ext = MatchGroupTc arg_tys rhs_ty origin
})
= do { dflags <- getDynFlags
; locn <- getSrcSpanDs
-
+ ; let matches
+ = if any (is_pat_syn_match origin) matches'
+ then filter (non_gen_wc origin) matches'
+ -- filter out the wild pattern fail alternatives
+ -- which have a do expansion origin
+ -- They generate spurious overlapping warnings
+ -- Due to pattern synonyms treated as refutable patterns
+ -- See Part 1's Wrinkle 1 in Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do
+ else matches'
; new_vars <- case matches of
[] -> newSysLocalsDs arg_tys
(m:_) ->
@@ -780,12 +790,17 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
-- Pattern match check warnings for /this match-group/.
-- @rhss_nablas@ is a flat list of covered Nablas for each RHS.
-- Each Match will split off one Nablas for its RHSs from this.
+ ; tracePm "matchWrapper"
+ (vcat [ ppr ctxt
+ , text "scrs" <+> ppr scrs
+ , text "matches group" <+> ppr matches
+ , text "matchPmChecked" <+> ppr (isMatchContextPmChecked dflags origin ctxt)])
; matches_nablas <-
if isMatchContextPmChecked dflags origin ctxt
-- See Note [Long-distance information] in GHC.HsToCore.Pmc
then addHsScrutTmCs (concat scrs) new_vars $
- pmcMatches (DsMatchContext ctxt locn) new_vars matches
+ pmcMatches origin (DsMatchContext ctxt locn) new_vars matches
-- When we're not doing PM checks on the match group,
-- we still need to propagate long-distance information.
@@ -828,6 +843,14 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
$ NEL.nonEmpty
$ replicate (length (grhssGRHSs m)) ldi_nablas
+ is_pat_syn_match :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
+ is_pat_syn_match origin (L _ (Match _ _ [l_pat] _)) | isDoExpansionGenerated origin = isPatSyn l_pat
+ is_pat_syn_match _ _ = False
+ -- generated match pattern that is not a wildcard
+ non_gen_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
+ non_gen_wc origin (L _ (Match _ _ ([L _ (WildPat _)]) _)) = not . isDoExpansionGenerated $ origin
+ non_gen_wc _ _ = True
+
{- Note [Long-distance information in matchWrapper]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The pattern match checking in matchWrapper is done conditionally, depending
@@ -1141,8 +1164,10 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- we have to compare the wrappers
exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap h' e'))) =
wrap h h' && exp e e'
- exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) =
- exp b b'
+ exp (XExpr (ExpandedThingTc o x)) (XExpr (ExpandedThingTc o' x'))
+ | isHsThingRnExpr o
+ , isHsThingRnExpr o'
+ = exp x x'
exp (HsVar _ i) (HsVar _ i') = i == i'
exp (XExpr (ConLikeTc c _ _)) (XExpr (ConLikeTc c' _ _)) = c == c'
-- the instance for IPName derives using the id, so this works if the
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index e4613fa831631e26fe49e83c7cc25cab352a1192..fd6d813fc71336c51bfaa172dd47ac269a1279b0 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -51,7 +51,7 @@ import GHC.HsToCore.Pmc.Utils
import GHC.HsToCore.Pmc.Desugar
import GHC.HsToCore.Pmc.Check
import GHC.HsToCore.Pmc.Solver
-import GHC.Types.Basic (Origin(..))
+import GHC.Types.Basic (Origin(..), isDoExpansionGenerated)
import GHC.Core
import GHC.Driver.DynFlags
import GHC.Hs
@@ -68,7 +68,7 @@ import GHC.HsToCore.Monad
import GHC.Data.Bag
import GHC.Data.OrdList
-import Control.Monad (when, forM_)
+import Control.Monad (when, unless, forM_)
import qualified Data.Semigroup as Semi
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
@@ -162,20 +162,21 @@ pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do
-- checks an @-XEmptyCase@ with only a single match variable.
-- See Note [Checking EmptyCase].
pmcMatches
- :: DsMatchContext -- ^ Match context, for warnings messages
+ :: Origin
+ -> DsMatchContext -- ^ Match context, for warnings messages
-> [Id] -- ^ Match variables, i.e. x and y above
-> [LMatch GhcTc (LHsExpr GhcTc)] -- ^ List of matches
-> DsM [(Nablas, NonEmpty Nablas)] -- ^ One covered 'Nablas' per Match and
-- GRHS, for long distance info.
-pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do
+pmcMatches origin ctxt vars matches = {-# SCC "pmcMatches" #-} do
-- We have to force @missing@ before printing out the trace message,
-- otherwise we get interleaved output from the solver. This function
-- should be strict in @missing@ anyway!
!missing <- getLdiNablas
tracePm "pmcMatches {" $
- hang (vcat [ppr ctxt, ppr vars, text "Matches:"])
+ hang (vcat [ppr origin, ppr ctxt, ppr vars, text "Matches:"])
2
- (vcat (map ppr matches) $$ ppr missing)
+ ((ppr matches) $$ (text "missing:" <+> ppr missing))
case NE.nonEmpty matches of
Nothing -> do
-- This must be an -XEmptyCase. See Note [Checking EmptyCase]
@@ -191,7 +192,9 @@ pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do
result <- {-# SCC "checkMatchGroup" #-}
unCA (checkMatchGroup matches) missing
tracePm "}: " (ppr (cr_uncov result))
- {-# SCC "formatReportWarnings" #-} formatReportWarnings ReportMatchGroup ctxt vars result
+ unless (isDoExpansionGenerated origin) -- Do expansion generated code shouldn't emit overlapping warnings
+ ({-# SCC "formatReportWarnings" #-}
+ formatReportWarnings ReportMatchGroup ctxt vars result)
return (NE.toList (ldiMatchGroup (cr_ret result)))
{-
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 04ebe88af69359312a9769f4e0f67f84ea8a05e4..97075c0c47cb8fa4c4a8d20b76d725c9ab907edc 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1684,11 +1684,16 @@ repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel .
repE (HsEmbTy _ t) = do
t1 <- repLTy (hswc_body t)
rep2 typeEName [unC t1]
-repE (XExpr (HsExpanded orig_expr ds_expr))
+repE e@(XExpr (ExpandedThingRn o x))
+ | OrigExpr e <- o
= do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
; if rebindable_on -- See Note [Quotation and rebindable syntax]
- then repE ds_expr
- else repE orig_expr }
+ then repE x
+ else repE e }
+ | otherwise
+ = notHandled (ThExpressionForm e)
+
+repE (XExpr (PopErrCtxt (L _ e))) = repE e
repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e)
repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)
@@ -1714,7 +1719,7 @@ Then, concerning the TH quotation,
a type error from the splice.
We consult the module-wide RebindableSyntax flag here. We could instead record
-the choice in HsExpanded, but it seems simpler to consult the flag (again).
+the choice in ExpandedThingRn, but it seems simpler to consult the flag (again).
-}
-----------------------------------------------------------------------------
diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs
index e33c09ca4f1990890ae7b6bc8fbd5d874737d845..5c93f9dbebedd799230ed63b76f9ad526d986cbe 100644
--- a/compiler/GHC/HsToCore/Ticks.hs
+++ b/compiler/GHC/HsToCore/Ticks.hs
@@ -304,7 +304,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
-- TODO: better name for rhs's for non-simple patterns?
let name = maybe "(...)" getOccString simplePatId
- (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
+ (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False False rhs
let pat' = pat { pat_rhs = rhs'}
-- Should create ticks here?
@@ -375,7 +375,9 @@ addTickLHsExpr e@(L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
- TickForCoverage -> tick_it
+ TickForCoverage | XExpr (ExpandedThingTc OrigStmt{} _) <- e0 -- expansion ticks are handled separately
+ -> dont_tick_it
+ | otherwise -> tick_it
TickCallSites | isCallSite e0 -> tick_it
_other -> dont_tick_it
where
@@ -440,28 +442,31 @@ addTickLHsExprNever (L pos e0) = do
-- General heuristic: expressions which are calls (do not denote
-- values) are good break points.
isGoodBreakExpr :: HsExpr GhcTc -> Bool
+isGoodBreakExpr (XExpr (ExpandedThingTc (OrigStmt{}) _)) = False
isGoodBreakExpr e = isCallSite e
isCallSite :: HsExpr GhcTc -> Bool
isCallSite HsApp{} = True
isCallSite HsAppType{} = True
-isCallSite (XExpr (ExpansionExpr (HsExpanded _ e)))
- = isCallSite e
+isCallSite HsCase{} = True
+isCallSite (XExpr (ExpandedThingTc _ e))
+ = isCallSite e
+
-- NB: OpApp, SectionL, SectionR are all expanded out
isCallSite _ = False
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprOptAlt oneOfMany (L pos e0)
+addTickLHsExprOptAlt oneOfMany e@(L pos e0)
= ifDensity TickForCoverage
(allocTickBox (ExpBox oneOfMany) False False (locA pos)
- $ addTickHsExpr e0)
- (addTickLHsExpr (L pos e0))
+ $ addTickHsExpr e0)
+ (addTickLHsExpr e)
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addBinTickLHsExpr boxLabel (L pos e0)
+addBinTickLHsExpr boxLabel e@(L pos e0)
= ifDensity TickForCoverage
(allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0)
- (addTickLHsExpr (L pos e0))
+ (addTickLHsExpr e)
-- -----------------------------------------------------------------------------
@@ -519,6 +524,7 @@ addTickHsExpr (HsCase x e mgs) =
(addTickLHsExpr e) -- not an EvalInner; e might not necessarily
-- be evaluated.
(addTickMatchGroup False mgs)
+
addTickHsExpr (HsIf x e1 e2 e3) =
liftM3 (HsIf x)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
@@ -526,20 +532,13 @@ addTickHsExpr (HsIf x e1 e2 e3) =
(addTickLHsExprOptAlt True e3)
addTickHsExpr (HsMultiIf ty alts)
= do { let isOneOfMany = case alts of [_] -> False; _ -> True
- ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False) alts
+ ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False) alts
; return $ HsMultiIf ty alts' }
addTickHsExpr (HsLet x binds e) =
bindLocals (collectLocalBinders CollNoDictBinders binds) $ do
binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
e' <- addTickLHsExprLetBody e
return (HsLet x binds' e')
-addTickHsExpr (HsDo srcloc cxt (L l stmts))
- = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
- ; return (HsDo srcloc cxt (L l stmts')) }
- where
- forQual = case cxt of
- ListComp -> Just $ BinBox QualBinBox
- _ -> Nothing
addTickHsExpr (ExplicitList ty es)
= liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es)
@@ -590,9 +589,7 @@ addTickHsExpr (HsProc x pat cmdtop) =
addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =
liftM (XExpr . WrapExpr . HsWrap w) $
(addTickHsExpr e) -- Explicitly no tick on inside
-addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) =
- liftM (XExpr . ExpansionExpr . HsExpanded a) $
- (addTickHsExpr b)
+addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e
addTickHsExpr e@(XExpr (ConLikeTc {})) = return e
-- We used to do a freeVar on a pat-syn builder, but actually
@@ -605,6 +602,29 @@ addTickHsExpr (XExpr (HsTick t e)) =
addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =
liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)
+addTickHsExpr (HsDo srcloc cxt (L l stmts))
+ = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
+ ; return (HsDo srcloc cxt (L l stmts')) }
+ where
+ forQual = case cxt of
+ ListComp -> Just $ BinBox QualBinBox
+ _ -> Nothing
+
+addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)
+addTickHsExpanded o@(OrigStmt (L pos LastStmt{})) e
+ -- LastStmt always gets a tick for breakpoint and hpc coverage
+ = do d <- getDensity
+ case d of
+ TickForCoverage -> liftM (XExpr . ExpandedThingTc o) $ tick_it e
+ TickForBreakPoints -> liftM (XExpr . ExpandedThingTc o) $ tick_it e
+ _ -> liftM (XExpr . ExpandedThingTc o) $ addTickHsExpr e
+ where
+ tick_it e = unLoc <$> allocTickBox (ExpBox False) False False (locA pos)
+ (addTickHsExpr e)
+addTickHsExpanded o e
+ = liftM (XExpr . ExpandedThingTc o) $ addTickHsExpr e
+
+
addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e
; return (Present x e') }
@@ -613,41 +633,51 @@ addTickTupArg (Missing ty) = return (Missing ty)
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
-addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
+addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches, mg_ext = ctxt }) = do
let isOneOfMany = matchesOneOfMany matches
- matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam)) matches
+ isDoExp = isDoExpansionGenerated $ mg_origin ctxt
+ matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam isDoExp)) matches
return $ mg { mg_alts = L l matches' }
-addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
+addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} -> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
-addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
- , m_grhss = gRHSs }) =
+addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = pats
+ , m_grhss = gRHSs }) =
bindLocals (collectPatsBinders CollNoDictBinders pats) $ do
- gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
+ gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp gRHSs
return $ match { m_grhss = gRHSs' }
-addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
+addTickGRHSs :: Bool -> Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
-addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) =
+addTickGRHSs isOneOfMany isLambda isDoExp (GRHSs x guarded local_binds) =
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
- guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda)) guarded
+ guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda isDoExp)) guarded
return $ GRHSs x guarded' local_binds'
where
binders = collectLocalBinders CollNoDictBinders local_binds
-addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
+addTickGRHS :: Bool -> Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
-> TM (GRHS GhcTc (LHsExpr GhcTc))
-addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
+addTickGRHS isOneOfMany isLambda isDoExp (GRHS x stmts expr) = do
(stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
- (addTickGRHSBody isOneOfMany isLambda expr)
+ (addTickGRHSBody isOneOfMany isLambda isDoExp expr)
return $ GRHS x stmts' expr'
-addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
+addTickGRHSBody :: Bool -> Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickGRHSBody isOneOfMany isLambda isDoExp expr@(L pos e0) = do
d <- getDensity
case d of
- TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr
+ TickForBreakPoints
+ | isDoExp -- ticks for do-expansions are handled by `addTickHsExpanded`
+ -> addTickLHsExprNever expr
+ | otherwise
+ -> addTickLHsExprRHS expr
+ TickForCoverage
+ | isDoExp -- ticks for do-expansions are handled by `addTickHsExpanded`
+ -> addTickLHsExprNever expr
+ | otherwise
+ -> addTickLHsExprOptAlt isOneOfMany expr
TickAllFunctions | isLambda ->
addPathEntry "\\" $
allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $
@@ -1057,6 +1087,7 @@ instance Monad TM where
(r2,fv2,st2) ->
(r2, fv1 `plusOccEnv` fv2, st2)
+
-- | Get the next HPC cost centre index for a given centre name
getCCIndexM :: FastString -> TM CostCentreIndex
getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $
@@ -1139,8 +1170,8 @@ allocTickBox boxLabel countEntries topOnly pos m =
(fvs, e) <- getFreeVars m
env <- getEnv
tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
- return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e))
- ) (do
+ return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e)))
+ (do
e <- m
return (L (noAnnSrcSpan pos) e)
)
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 021101e96d50cc78f2af45618396506df52588c2..4c4a04997c53e2a5a974c2d55ade31f36497edd6 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -743,8 +743,10 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where
RecordCon con_expr _ _ -> computeType con_expr
ExprWithTySig _ e _ -> computeLType e
HsPragE _ _ e -> computeLType e
- XExpr (ExpansionExpr (HsExpanded (HsGetField _ _ _) e)) -> Just (hsExprType e) -- for record-dot-syntax
- XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e
+ XExpr (ExpandedThingTc thing e)
+ | OrigExpr (HsGetField{}) <- thing -- for record-dot-syntax
+ -> Just (hsExprType e)
+ | otherwise -> computeType e
XExpr (HsTick _ e) -> computeLType e
XExpr (HsBinTick _ _ e) -> computeLType e
e -> Just (hsExprType e)
@@ -1127,7 +1129,7 @@ the typechecker:
to ol_from_fun.
* HsDo, where we give the SrcSpan of the entire do block to each
ApplicativeStmt.
- * HsExpanded ExplicitList{}, where we give the SrcSpan of the original
+ * Expanded (via ExpandedThingRn) ExplicitList{}, where we give the SrcSpan of the original
list expression to the 'fromListN' call.
In order for the implicit function calls to not be confused for actual
@@ -1298,8 +1300,8 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
WrapExpr (HsWrap w a)
-> [ toHie $ L mspan a
, toHie (L mspan w) ]
- ExpansionExpr (HsExpanded _ b)
- -> [ toHie (L mspan b) ]
+ ExpandedThingTc _ e
+ -> [ toHie (L mspan e) ]
ConLikeTc con _ _
-> [ toHie $ C Use $ L mspan $ conLikeName con ]
HsTick _ expr
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index a26ed9d1203381e386b1a502908c6b1c3c2540e4..36783056f32e82d0fdc469b98773652eb6161ff6 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/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
@@ -47,7 +47,7 @@ import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames
, checkUnusedRecordWildcard
, wrapGenSpan, genHsIntegralLit, genHsTyLit
, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps'
- , genAppType, isIrrefutableHsPatRn )
+ , genAppType, isIrrefutableHsPat )
import GHC.Rename.Unbound ( reportUnboundName )
import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnTypedSplice, rnUntypedSpliceExpr, checkThLocalName )
import GHC.Rename.HsType
@@ -87,18 +87,26 @@ import qualified Data.List.NonEmpty as NE
{- Note [Handling overloaded and rebindable constructs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Nomenclature
+-------------
+* Expansion (`HsExpr GhcRn -> HsExpr GhcRn`): expand between renaming and
+ typechecking, using the `XXExprGhcRn` constructor of `HsExpr`.
+* Desugaring (`HsExpr GhcTc -> Core.Expr`): convert the typechecked `HsSyn` to Core. This is done in GHC.HsToCore
+
+
For overloaded constructs (overloaded literals, lists, strings), and
rebindable constructs (e.g. if-then-else), our general plan is this,
using overloaded labels #foo as an example:
* In the RENAMER: transform
HsOverLabel "foo"
- ==> XExpr (HsExpansion (HsOverLabel #foo)
- (fromLabel `HsAppType` "foo"))
+ ==> XExpr (ExpandedThingRn (HsOverLabel #foo)
+ (fromLabel `HsAppType` "foo"))
We write this more compactly in concrete-syntax form like this
#foo ==> fromLabel @"foo"
- Recall that in (HsExpansion orig expanded), 'orig' is the original term
+ Recall that in (ExpandedThingRn orig expanded), 'orig' is the original term
the user wrote, and 'expanded' is the expanded or desugared version
to be typechecked.
@@ -107,7 +115,7 @@ using overloaded labels #foo as an example:
The typechecker (and desugarer) will never see HsOverLabel
In effect, the renamer does a bit of desugaring. Recall GHC.Hs.Expr
-Note [Rebindable syntax and HsExpansion], which describes the use of HsExpansion.
+Note [Rebindable syntax and XXExprGhcRn], which describes the use of XXExprGhcRn.
RebindableSyntax:
If RebindableSyntax is off we use the built-in 'fromLabel', defined in
@@ -133,7 +141,7 @@ but several have a little bit of special treatment:
* OverLabel (overloaded labels, #lbl)
#lbl ==> fromLabel @"lbl"
As ever, we use lookupSyntaxName to look up 'fromLabel'
- See Note [Overloaded labels]
+ See Note [Overloaded labels] below
* ExplicitList (explicit lists [a,b,c])
When (and only when) OverloadedLists is on
@@ -147,13 +155,8 @@ but several have a little bit of special treatment:
where `leftSection` and `rightSection` are representation-polymorphic
wired-in Ids. See Note [Left and right sections]
-* It's a bit painful to transform `OpApp e1 op e2` to a `HsExpansion`
- form, because the renamer does precedence rearrangement after name
- resolution. So the renamer leaves an OpApp as an OpApp.
-
- The typechecker turns `OpApp` into a use of `HsExpansion`
- on the fly, in GHC.Tc.Gen.Head.splitHsApps. RebindableSyntax
- does not affect this.
+* To understand why expansions for `OpApp` is done in `GHC.Tc.Gen.Head.splitHsApps`
+ see Note [Doing XXExprGhcRn in the Renamer vs Typechecker] below.
* RecordUpd: we desugar record updates into case expressions,
in GHC.Tc.Gen.Expr.tcExpr.
@@ -175,20 +178,24 @@ but several have a little bit of special treatment:
See Note [Record Updates] in GHC.Tc.Gen.Expr for more details.
- This is done in the typechecker, not the renamer, for two reasons:
+ To understand Why is this done in the typechecker, and not in the renamer
+ see Note [Doing XXExprGhcRn in the Renamer vs Typechecker]
- - (Until we implement GHC proposal #366)
- We need to know the type of the record to disambiguate its fields.
+* HsDo: We expand `HsDo` statements in `Ghc.Tc.Gen.Do`.
- - We use the type signature of the data constructor to provide IdSigs
- to the let-bound variables (x', y' in the example above). This is
- needed to accept programs such as
+ - For example, a user written code:
- data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int }
- foo r = r { f = \ k -> (k 3, k 'x') }
+ do { x <- e1 ; g x ; return (f x) }
- in which an updated field has a higher-rank type.
- See Wrinkle [Using IdSig] in Note [Record Updates] in GHC.Tc.Gen.Expr.
+ is expanded to:
+
+ (>>=) e1
+ (\x -> ((>>) (g x)
+ (return (f x))))
+
+ See Note [Expanding HsDo with XXExprGhcRn] in `Ghc.Tc.Gen.Do` for more details.
+ To understand why is this done in the typechecker and not in the renamer.
+ See Note [Doing XXExprGhcRn in the Renamer vs Typechecker]
Note [Overloaded labels]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -208,6 +215,66 @@ type-applying to "foo", so we get
And those inferred kind quantifiers will indeed be instantiated when we
typecheck the renamed-syntax call (fromLabel @"foo").
+
+Note [Doing XXExprGhcRn in the Renamer vs Typechecker]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We expand some `HsExpr GhcRn` code at various places, usually, on the fly,
+depending on when it is more convenient. It may be beneficial to have a
+separate `HsExpr GhcRn -> HsExpr GhcRn` pass that does this expansion uniformly
+in the future when we have enough cases to cater for. For the time being,
+this note documents which language feature is expanded at which phase,
+and the reasons for doing so.
+
+ ** `HsIf` Expansions
+ --------------------
+ `HsIf` expansions are expanded in the Renamer becuase it is more convinent
+ to do so there and then not worry about it in the later stage.
+ `-XRebindableSyntax` is used to decide whether we use the `HsIf` or user defined if
+
+
+ ** `OpApp` Expansions
+ ---------------------
+ The typechecker turns `OpApp` into a use of `XXExprGhcRn`
+ on the fly, in `GHC.Tc.Gen.Head.splitHsApps`.
+ The language extension `RebindableSyntax` does not affect this behaviour.
+
+ It's a bit painful to transform `OpApp e1 op e2` to a `XXExprGhcRn`
+ form, because the renamer does precedence rearrangement after name
+ resolution. So the renamer leaves an `OpApp` as an `OpApp`.
+
+ ** Record Update Syntax `RecordUpd` Expansions
+ ----------------------------------------------
+ This is done in the typechecker on the fly (`GHC.Tc.Expr.tcExpr`), and not the renamer, for two reasons:
+
+ - (Until we implement GHC proposal #366)
+ We need to know the type of the record to disambiguate its fields.
+
+ - We use the type signature of the data constructor to provide `IdSigs`
+ to the let-bound variables (x', y' in the example of
+ Note [Handling overloaded and rebindable constructs] above).
+ This is needed to accept programs such as
+
+ data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int }
+ foo r = r { f = \ k -> (k 3, k 'x') }
+
+ in which an updated field has a higher-rank type.
+ See Wrinkle [Using IdSig] in Note [Record Updates] in GHC.Tc.Gen.Expr.
+
+ ** `HsDo` Statement Expansions
+ -----------------------------------
+ The expansion for do block statements is done on the fly right before typechecking in `GHC.Tc.Gen.Expr`
+ using `GHC.Tc.Gen.Do.expandDoStmts`. There are 2 main reasons:
+
+ - During the renaming phase, we may not have all the constructor details `HsConDetails` populated in the
+ data structure. This would result in an inaccurate irrefutability analysis causing
+ the continuation lambda body to be wrapped with `fail` alternatives when not needed.
+ See Part 1. of Note [Expanding HsDo with XXExprGhcRn] (test pattern-fails.hs)
+
+ - If the expansion is done on the fly during renaming, expressions that
+ have explicit type applications using (-XTypeApplciations) will not work (cf. Let statements expansion)
+ as the name freshening happens from the root of the AST to the leaves,
+ but the expansion happens in the opposite direction (from leaves to the root),
+ causing the renamer to miss the scoped type variables.
-}
{-
@@ -436,7 +503,6 @@ rnExpr (HsDo _ do_or_lc (L l stmts))
(\ _ -> return ((), emptyFVs))
; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
; 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
@@ -526,24 +592,7 @@ rnExpr (ExprWithTySig _ expr pty)
-- HsIf: see Note [Handling overloaded and rebindable constructs]
-- Because of the coverage checker it is most convenient /not/ to
-- expand HsIf; unless we are in rebindable syntax.
-rnExpr (HsIf _ p b1 b2)
- = do { (p', fvP) <- rnLExpr p
- ; (b1', fvB1) <- rnLExpr b1
- ; (b2', fvB2) <- rnLExpr b2
- ; let fvs_if = plusFVs [fvP, fvB1, fvB2]
- rn_if = HsIf noExtField p' b1' b2'
-
- -- Deal with rebindable syntax
- -- See Note [Handling overloaded and rebindable constructs]
- ; mb_ite <- lookupIfThenElse
- ; case mb_ite of
- Nothing -- Non rebindable-syntax case
- -> return (rn_if, fvs_if)
-
- Just ite_name -- Rebindable-syntax case
- -> do { let ds_if = genHsApps ite_name [p', b1', b2']
- fvs = plusFVs [fvs_if, unitFV ite_name]
- ; return (mkExpandedExpr rn_if ds_if, fvs) } }
+rnExpr (HsIf _ p b1 b2) = rnHsIf p b1 b2
rnExpr (HsMultiIf _ alts)
= do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
@@ -1177,7 +1226,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 []
@@ -1823,7 +1872,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
@@ -2320,7 +2369,7 @@ of a refutable pattern, in order for the types to work out.
hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool
hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat
, is_body_stmt = False}) =
- not (isIrrefutableHsPatRn dflags pat)
+ not (isIrrefutableHsPat dflags pat)
hasRefutablePattern _ _ = False
isLetStmt :: LStmt (GhcPass a) b -> Bool
@@ -2632,7 +2681,7 @@ monadFailOp pat ctxt = do
dflags <- getDynFlags
-- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
-- we should not need to fail.
- if | isIrrefutableHsPatRn dflags pat -> return (Nothing, emptyFVs)
+ if | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs)
-- For non-monadic contexts (e.g. guard patterns, list
-- comprehensions, etc.) we should not need to fail, or failure is handled in
@@ -2707,19 +2756,31 @@ getMonadFailOp ctxt
{- *********************************************************************
* *
- Generating code for HsExpanded
+ Generating code for ExpandedThingRn
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)
+-- | Expand `HsIf` if rebindable syntax is turned on
+-- See Note [Handling overloaded and rebindable constructs]
+rnHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+rnHsIf p b1 b2
+ = do { (p', fvP) <- rnLExpr p
+ ; (b1', fvB1) <- rnLExpr b1
+ ; (b2', fvB2) <- rnLExpr b2
+ ; let fvs_if = plusFVs [fvP, fvB1, fvB2]
+ rn_if = HsIf noExtField p' b1' b2'
+
+ -- Deal with rebindable syntax
+ ; mb_ite <- lookupIfThenElse
+ ; case mb_ite of
+ Nothing -- Non rebindable-syntax case
+ -> return (rn_if, fvs_if)
+
+ Just ite_name -- Rebindable-syntax case
+ -> do { let ds_if = genHsApps ite_name [p', b1', b2']
+ fvs = plusFVs [fvs_if, unitFV ite_name]
+ ; return (mkExpandedExpr rn_if ds_if, fvs) } }
-----------------------------------------
-- Bits and pieces for RecordDotSyntax.
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 4dfa56a389d4a2d2ab62e2d43e6c372e3b802abd..211d872ecfca185acc68067218065ff88ee6bad7 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -314,7 +314,7 @@ Note [Handling overloaded and rebindable patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Overloaded patterns and rebindable patterns are desugared in the renamer
using the HsPatExpansion mechanism detailed in:
-Note [Rebindable syntax and HsExpansion]
+Note [Rebindable syntax and XXExprGhcRn]
The approach is similar to that of expressions, which is further detailed
in Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.
@@ -342,7 +342,7 @@ If OverloadedLists is enabled, we desugar a list pattern to a view pattern:
toList -> [p1, p2, p3]
This happens directly in the renamer, using the HsPatExpansion mechanism
-detailed in Note [Rebindable syntax and HsExpansion].
+detailed in Note [Rebindable syntax and XXExprGhcRn].
Note that we emit a special view pattern: we additionally keep track of an
inverse to the pattern.
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 087f052ac77582d1a698502e4afe205644b4c7a4..ea01e8195741544a7f1c7f52e0e83e16ab1fe1a9 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -20,12 +20,16 @@ module GHC.Rename.Utils (
DeprecationWarnings(..), warnIfDeprecated,
checkUnusedRecordWildcard,
badQualBndrErr, typeAppErr, badFieldConErr,
- wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genLHsApp,
- genAppType,
+ wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genHsExpApps,
+ genLHsApp, genAppType,
genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat,
genVarPat, genWildPat,
genSimpleFunBind, genFunBind,
+ genHsLamDoExp, genHsCaseAltDoExp, genSimpleMatch,
+
+ genHsLet,
+
newLocalBndrRn, newLocalBndrsRn,
bindLocalNames, bindLocalNamesFV, delLocalNames,
@@ -35,7 +39,7 @@ module GHC.Rename.Utils (
checkInferredVars,
noNestedForallsContextsErr, addNoNestedForallsContextsErr,
- isIrrefutableHsPatRn
+ isIrrefutableHsPat
)
where
@@ -701,14 +705,14 @@ checkCTupSize tup_size
{- *********************************************************************
* *
- Generating code for HsExpanded
+ Generating code for ExpandedThingRn
See Note [Handling overloaded and rebindable constructs]
* *
********************************************************************* -}
wrapGenSpan :: (NoAnn an) => a -> LocatedAn an a
-- Wrap something in a "generatedSrcSpan"
--- See Note [Rebindable syntax and HsExpansion]
+-- See Note [Rebindable syntax and XXExprGhcRn]
wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
@@ -719,6 +723,9 @@ genHsApps' :: LocatedN Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps' (L _ fun) [] = genHsVar fun
genHsApps' (L loc fun) (arg:args) = foldl genHsApp (unLoc $ mkHsApp (L (l2l loc) $ genHsVar fun) arg) args
+genHsExpApps :: HsExpr GhcRn -> [LHsExpr GhcRn] -> HsExpr GhcRn
+genHsExpApps fun arg = foldl genHsApp fun arg
+
genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg
@@ -773,11 +780,47 @@ genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBind GhcRn
genFunBind fn ms
= FunBind { fun_id = fn
- , fun_matches = mkMatchGroup (Generated SkipPmc) (wrapGenSpan ms)
+ , fun_matches = mkMatchGroup (Generated OtherExpansion SkipPmc) (wrapGenSpan ms)
, fun_ext = emptyNameSet
}
-isIrrefutableHsPatRn :: forall p. (OutputableBndrId p)
- => DynFlags -> LPat (GhcPass p) -> Bool
-isIrrefutableHsPatRn dflags =
- isIrrefutableHsPat (xopt LangExt.Strict dflags)
+isIrrefutableHsPat :: forall p. (OutputableBndrId p) => DynFlags -> LPat (GhcPass p) -> Bool
+isIrrefutableHsPat dflags =
+ isIrrefutableHsPatHelper (xopt LangExt.Strict dflags)
+
+genHsLet :: HsLocalBindsLR GhcRn GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
+genHsLet bindings body = HsLet noExtField bindings body
+
+genHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
+ => HsDoFlavour
+ -> [LPat (GhcPass p)]
+ -> LHsExpr (GhcPass p)
+ -> LHsExpr (GhcPass p)
+genHsLamDoExp doFlav pats body = mkHsPar (wrapGenSpan $ HsLam noAnn LamSingle matches)
+ where
+ matches = mkMatchGroup (doExpansionOrigin doFlav)
+ (wrapGenSpan [genSimpleMatch (StmtCtxt (HsDoStmt doFlav)) pats' body])
+ pats' = map (parenthesizePat appPrec) pats
+
+
+genHsCaseAltDoExp :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ EpAnnCO,
+ Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpanAnnA)
+ => HsDoFlavour -> LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))
+ -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
+genHsCaseAltDoExp doFlav pat expr
+ = genSimpleMatch (StmtCtxt (HsDoStmt doFlav)) [pat] expr
+
+
+genSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpanAnnA,
+ Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ EpAnnCO)
+ => HsMatchContext (GhcPass p)
+ -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
+ -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
+genSimpleMatch ctxt pats rhs
+ = wrapGenSpan $
+ Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats
+ , m_grhss = unguardedGRHSs generatedSrcSpan rhs noAnn }
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index ac62cf384d45a1d581f624cfff53a8dcf063b256..ac40a1d1bcea5e1f50f41b7f5b53688609757454 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -2292,7 +2292,7 @@ mkFunBindSE arity loc fun pats_and_exprs
mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBind fun@(L loc _fun_rdr) matches
- = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches)
+ = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches)
-- | Make a function binding. If no equations are given, produce a function
-- with the given arity that uses an empty case expression for the last
@@ -2320,7 +2320,7 @@ mkRdrFunBindEC :: Arity
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
- = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches')
+ = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches')
where
-- Catch-all eqn looks like
-- fmap _ z = case z of {}
@@ -2344,7 +2344,7 @@ mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
mkRdrFunBindSE :: Arity -> LocatedN RdrName ->
[LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
- = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches')
+ = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches')
where
-- Catch-all eqn looks like
-- compare _ _ = error "Void compare"
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 27b73bea6c3a8c505e89fbdc3705138b47f4cd62..95708e472227ad634122c63a4bb4c60e0f7cd83b 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -4948,7 +4948,7 @@ pprWithArising (ct:cts)
{- Note ["Arising from" messages in generated code]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider code generated when we desugar code before typechecking;
-see Note [Rebindable syntax and HsExpansion].
+see Note [Rebindable syntax and XXExprGhcRn].
In this code, constraints may be generated, but we don't want to
say "arising from a call of foo" if 'foo' doesn't appear in the
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index a81c3b2175531f394b96db8ae746c3678d2ffee3..ce8779665203b335e517f64afa40fcba205873b9 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+{-# LANGUAGE TypeApplications #-} -- Wrinkle in Note [Trees That Grow]
{-
%
@@ -323,7 +324,9 @@ tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp rn_expr exp_res_ty
= do { (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr
; traceTc "tcApp {" $
- vcat [ text "rn_fun:" <+> ppr rn_fun
+ vcat [ text "rn_expr:" <+> ppr rn_expr
+ , text "rn_fun:" <+> ppr rn_fun
+ , text "fun_ctxt:" <+> ppr fun_ctxt
, text "rn_args:" <+> ppr rn_args ]
; (tc_fun, fun_sigma) <- tcInferAppHead fun
@@ -346,7 +349,7 @@ tcApp rn_expr exp_res_ty
-- Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
; let perhaps_add_res_ty_ctxt thing_inside
| insideExpansion fun_ctxt
- = thing_inside
+ = addHeadCtxt fun_ctxt thing_inside
| otherwise
= addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $
thing_inside
@@ -525,14 +528,22 @@ tcInstFun :: Bool -- True <=> Do quick-look
-- modification in Fig 5, of the QL paper:
-- "A quick look at impredicativity" (ICFP'20).
tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
- = do { traceTc "tcInstFun" (vcat [ ppr tc_fun, ppr fun_sigma
+ = do { traceTc "tcInstFun" (vcat [ text "tc_fun" <+> ppr tc_fun
+ , text "fun_sigma" <+> ppr fun_sigma
+ , text "fun_ctxt" <+> ppr fun_ctxt
, text "args:" <+> ppr rn_args
, text "do_ql" <+> ppr do_ql ])
; go emptyVarSet [] [] fun_sigma rn_args }
where
- fun_orig = exprCtOrigin (case fun_ctxt of
- VAExpansion e _ _ -> e
- VACall e _ _ -> e)
+ fun_orig
+ | VAExpansion (OrigStmt{}) _ _ <- fun_ctxt
+ = DoOrigin
+ | VAExpansion (OrigPat pat) _ _ <- fun_ctxt
+ = DoPatOrigin pat
+ | VAExpansion (OrigExpr e) _ _ <- fun_ctxt
+ = exprCtOrigin e
+ | VACall e _ _ <- fun_ctxt
+ = exprCtOrigin e
-- These are the type variables which must be instantiated to concrete
-- types. See Note [Representation-polymorphic Ids with no binding]
@@ -708,25 +719,28 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
-- Rule IARG from Fig 4 of the QL paper:
go1 delta acc so_far fun_ty
(eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args)
- = do { (wrap, arg_ty, res_ty) <-
+ = do { let herald = case fun_ctxt of
+ VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun
+ _ -> ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
+ ; (wrap, arg_ty, res_ty) <-
-- NB: matchActualFunTySigma does the rep-poly check.
-- For example, suppose we have f :: forall r (a::TYPE r). a -> Int
-- In an application (f x), we need 'x' to have a fixed runtime
-- representation; matchActualFunTySigma checks that when
-- taking apart the arrow type (a -> Int).
matchActualFunTySigma
- (ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg))
+ herald
(Just $ HsExprTcThing tc_fun)
(n_val_args, so_far) fun_ty
- ; (delta', arg') <- if do_ql
+ ; (delta', arg') <- if do_ql
then addArgCtxt ctxt arg $
-- Context needed for constraints
-- generated by calls in arg
quickLookArg delta arg arg_ty
else return (delta, ValArg arg)
- ; let acc' = eva { eva_arg = arg', eva_arg_ty = arg_ty }
+ ; let acc' = eva { eva_arg = arg', eva_arg_ty = arg_ty }
: addArgWrap wrap acc
- ; go delta' acc' (arg_ty:so_far) res_ty rest_args }
+ ; go delta' acc' (arg_ty:so_far) res_ty rest_args }
-- Is the argument supposed to instantiate a forall?
--
@@ -756,26 +770,49 @@ looks_like_type_arg _ = False
addArgCtxt :: AppCtxt -> LHsExpr GhcRn
-> TcM a -> TcM a
--- There are two cases:
--- * In the normal case, we add an informative context
--- "In the third argument of f, namely blah"
--- * If we are deep inside generated code (isGeneratedCode)
--- or if all or part of this particular application is an expansion
--- (VAExpansion), just use the less-informative context
--- "In the expression: arg"
+-- There are four cases:
+-- 1. In the normal case, we add an informative context
+-- "In the third argument of f, namely blah"
+-- 2. If we are deep inside generated code (`isGeneratedCode` is `True`)
+-- or if all or part of this particular application is an expansion
+-- `VAExpansion`, just use the less-informative context
+-- "In the expression: arg"
-- Unless the arg is also a generated thing, in which case do nothing.
----See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
+-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
+-- 3. We are in an expanded `do`-block's non-bind statement
+-- we simply add the statement context
+-- "In the statement of the `do`-block .."
+-- 4. We are in an expanded do block's bind statement
+-- a. Then either we are typechecking the first argument of the bind which is user located
+-- so we set the location to be that of the argument
+-- b. Or, we are typechecking the second argument which would be a generated lambda
+-- so we set the location to be whatever the location in the context is
+-- See Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do
addArgCtxt ctxt (L arg_loc arg) thing_inside
= do { in_generated_code <- inGeneratedCode
; case ctxt of
VACall fun arg_no _ | not in_generated_code
- -> setSrcSpanA arg_loc $
- addErrCtxt (funAppCtxt fun arg arg_no) $
- thing_inside
+ -> do setSrcSpanA arg_loc $
+ addErrCtxt (funAppCtxt fun arg arg_no) $
+ thing_inside
+
+ VAExpansion (OrigStmt (L _ stmt@(BindStmt {}))) _ loc
+ | isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=)
+ -> setSrcSpan loc $
+ addStmtCtxt stmt $
+ thing_inside
+ | otherwise -- This arg is the first argument to generated (>>=)
+ -> setSrcSpanA arg_loc $
+ addStmtCtxt stmt $
+ thing_inside
+ VAExpansion (OrigStmt (L loc stmt)) _ _
+ -> setSrcSpanA loc $
+ addStmtCtxt stmt $
+ thing_inside
_ -> setSrcSpanA arg_loc $
- addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
- thing_inside }
+ addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
+ thing_inside }
{- *********************************************************************
* *
@@ -907,7 +944,7 @@ expr_to_type earg =
| otherwise = not_in_scope
where occ = occName rdr
not_in_scope = failWith $ mkTcRnNotInScope rdr NotInScope
- go (L l (XExpr (HsExpanded orig _))) =
+ go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _))) =
-- Use the original, user-written expression (before expansion).
-- Example. Say we have vfun :: forall a -> blah
-- and the call vfun (Maybe [1,2,3])
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index 69bbe17654e252609d5deaaaa4cfc4dbd1e0ff8e..aa76e3948ac0c062d31be50c791ea28542596d19 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -263,7 +263,7 @@ tc_cmd env cmd@(HsCmdLam x lam_variant match) cmd_ty
LamSingle -> id -- Avoids clutter in the vanilla-lambda form
_ -> addErrCtxt (cmdCtxt cmd)) $
do { let match_ctxt = ArrowLamAlt lam_variant
- ; checkArgCounts (ArrowMatchCtxt match_ctxt) match
+ ; checkArgCounts (Just (ArrowMatchCtxt match_ctxt)) match
; (wrap, match') <- tcCmdMatchLambda env match_ctxt match cmd_ty
; return (mkHsCmdWrap wrap (HsCmdLam x lam_variant match')) }
@@ -319,11 +319,9 @@ tcCmdMatches :: CmdEnv
-> CmdType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))
tcCmdMatches env scrut_ty matches (stk, res_ty)
- = tcMatchesCase match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty)
+ = tcMatchesCase match_body_checker (unrestricted scrut_ty) matches (mkCheckExpType res_ty)
where
- match_ctxt = MC { mc_what = ArrowMatchCtxt ArrowCaseAlt,
- mc_body = mc_body }
- mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
+ match_body_checker body res_ty' = do { res_ty' <- expTypeToType res_ty'
; tcCmd env body (stk, res_ty') }
-- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'.
diff --git a/compiler/GHC/Tc/Gen/Do.hs b/compiler/GHC/Tc/Gen/Do.hs
new file mode 100644
index 0000000000000000000000000000000000000000..eac8687b0113f87f72c6397ddccc99c454d78e74
--- /dev/null
+++ b/compiler/GHC/Tc/Gen/Do.hs
@@ -0,0 +1,475 @@
+
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+(c) The University of Iowa 2023
+
+-}
+
+-- | Expand @Do@ block statements into @(>>=)@, @(>>)@ and @let@s
+-- After renaming but right ebefore type checking
+module GHC.Tc.Gen.Do (expandDoStmts) where
+
+import GHC.Prelude
+
+import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,
+ genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
+import GHC.Tc.Utils.Monad
+import GHC.Tc.Gen.Pat
+import GHC.Tc.Utils.TcMType
+
+import GHC.Hs
+
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Driver.DynFlags ( DynFlags, getDynFlags )
+import GHC.Driver.Ppr (showPpr)
+
+import GHC.Types.SrcLoc
+import GHC.Types.Basic
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.List ((\\))
+
+
+{-
+************************************************************************
+* *
+\subsection{XXExprGhcRn for Do Statements}
+* *
+************************************************************************
+-}
+
+-- | Expand the `do`-statments into expressions right after renaming
+-- so that they can be typechecked.
+-- See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary
+-- and Note [Handling overloaded and rebindable constructs] for high level commentary
+expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts
+ case expanded_expr of
+ L _ (XExpr (PopErrCtxt e)) -> return e
+ -- The first expanded stmt doesn't need a pop as
+ -- it would otherwise pop the "In the expression do ... " from
+ -- the error context
+ _ -> return expanded_expr
+
+-- | The main work horse for expanding do block statements into applications of binds and thens
+-- See Note [Expanding HsDo with XXExprGhcRn]
+expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+
+expand_do_stmts ListComp _ =
+ pprPanic "expand_do_stmts: impossible happened. ListComp" empty
+ -- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
+
+expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
+
+expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) =
+ pprPanic "expand_do_stmts: TransStmt" $ ppr stmt
+ -- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
+
+expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
+ pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
+ -- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
+
+expand_do_stmts _ (stmt@(L _ (ApplicativeStmt{})): _) =
+ pprPanic "expand_do_stmts: Applicative Stmt" $ ppr stmt
+ -- Handeled by tcSyntaxOp see `GHC.Tc.Gen.Match.tcStmtsAndThen`
+
+
+expand_do_stmts _ [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
+-- See Note [Expanding HsDo with XXExprGhcRn] Equation (5) below
+-- last statement of a list comprehension, needs to explicitly return it
+-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
+ | NoSyntaxExprRn <- ret_expr
+ -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
+ = do traceTc "expand_do_stmts last" (ppr ret_expr)
+ return $ mkExpandedStmtPopAt loc stmt body
+
+ | SyntaxExprRn ret <- ret_expr
+ --
+ -- ------------------------------------------------
+ -- return e ~~> return e
+ -- to make T18324 work
+ = do traceTc "expand_do_stmts last" (ppr ret_expr)
+ let expansion = genHsApp ret (L body_loc body)
+ return $ mkExpandedStmtPopAt loc stmt expansion
+
+expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bs)) : lstmts) =
+-- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
+-- stmts ~~> stmts'
+-- ------------------------------------------------
+-- let x = e ; stmts ~~> let x = e in stmts'
+ do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ let expansion = genHsLet bs expand_stmts
+ return $ mkExpandedStmtPopAt loc stmt expansion
+
+expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
+ | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
+ , fail_op <- xbsrn_failOp xbsrn
+-- See Note [Expanding HsDo with XXExprGhcRn] Equation (2) below
+-- the pattern binding pat can fail
+-- stmts ~~> stmt' f = \case pat -> stmts';
+-- _ -> fail "Pattern match failure .."
+-- -------------------------------------------------------
+-- pat <- e ; stmts ~~> (>>=) e f
+ = do expand_stmts <- expand_do_stmts do_or_lc lstmts
+ failable_expr <- mk_failable_expr do_or_lc pat expand_stmts fail_op
+ let expansion = genHsExpApps bind_op -- (>>=)
+ [ e
+ , failable_expr ]
+ return $ mkExpandedStmtPopAt loc stmt expansion
+
+ | otherwise
+ = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
+
+expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
+-- See Note [BodyStmt] in Language.Haskell.Syntax.Expr
+-- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below
+-- stmts ~~> stmts'
+-- ----------------------------------------------
+-- e ; stmts ~~> (>>) e stmts'
+ do expand_stmts_expr <- expand_do_stmts do_or_lc lstmts
+ let expansion = genHsExpApps then_op -- (>>)
+ [ e
+ , expand_stmts_expr ]
+ return $ mkExpandedStmtPopAt loc stmt expansion
+
+expand_do_stmts do_or_lc
+ ((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
+ , recS_later_ids = later_ids -- forward referenced local ids
+ , recS_rec_ids = local_ids -- ids referenced outside of the rec block
+ , recS_bind_fn = SyntaxExprRn bind_fun -- the (>>=) expr
+ , 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] in Language.Haskell.Syntax.Expr
+-- See Note [Expanding HsDo with XXExprGhcRn] Equation (4) and (6) below
+-- 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
+ -- NB: No need to wrap the expansion with an ExpandedStmt
+ -- as we want to flatten the rec block statements into its parent do block anyway
+ return $ mkHsApps (wrapGenSpan bind_fun) -- (>>=)
+ [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
+ , genHsLamDoExp do_or_lc [ 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 = wrapGenSpan $ LastStmt noExtField
+ (mkBigLHsTup (map nlHsVar all_ids) noExtField)
+ Nothing
+ (SyntaxExprRn return_fun)
+ do_stmts :: XRec GhcRn [ExprLStmt GhcRn]
+ do_stmts = L stmts_loc $ rec_stmts ++ [return_stmt]
+ do_block :: LHsExpr GhcRn
+ do_block = L loc $ HsDo noExtField do_or_lc do_stmts
+ mfix_expr :: LHsExpr GhcRn
+ mfix_expr = genHsLamDoExp do_or_lc [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ]
+ $ do_block
+ -- NB: LazyPat because we do not want to eagerly evaluate the pattern
+ -- and potentially loop forever
+
+expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
+
+-- checks the pattern `pat`for irrefutability which decides if we need to wrap it with a fail block
+mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
+mk_failable_expr doFlav pat@(L loc _) expr fail_op =
+ do { is_strict <- xoptM LangExt.Strict
+ ; irrf_pat <- isIrrefutableHsPatRnTcM is_strict pat
+ ; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat
+ , text "isIrrefutable:" <+> ppr irrf_pat
+ ])
+
+ ; if irrf_pat -- don't wrap with fail block if
+ -- the pattern is irrefutable
+ then return $ genHsLamDoExp doFlav [pat] expr
+ else L loc <$> mk_fail_block doFlav pat expr fail_op
+ }
+
+-- makes the fail block with a given fail_op
+mk_fail_block :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
+mk_fail_block doFlav pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
+ do dflags <- getDynFlags
+ return $ HsLam noAnn LamSingle $ mkMatchGroup (doExpansionOrigin doFlav) -- \
+ (wrapGenSpan [ genHsCaseAltDoExp doFlav pat e -- pat -> expr
+ , fail_alt_case dflags pat fail_op -- _ -> fail "fail pattern"
+ ])
+ where
+ fail_alt_case :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
+ fail_alt_case dflags pat fail_op = genHsCaseAltDoExp doFlav genWildPat $
+ L ploc (fail_op_expr dflags pat fail_op)
+
+ fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
+ fail_op_expr dflags pat fail_op
+ = mkExpandedPatRn pat $
+ genHsApp fail_op (mk_fail_msg_expr dflags pat)
+
+ mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
+ mk_fail_msg_expr dflags pat
+ = nlHsLit $ mkHsString $ showPpr dflags $
+ text "Pattern match failure in" <+> pprHsDoFlavour (DoExpr Nothing)
+ <+> text "at" <+> ppr (getLocA pat)
+
+
+mk_fail_block _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
+
+
+{- Note [Expanding HsDo with XXExprGhcRn]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We expand `do`-blocks before typechecking it, by re-using the existing `XXExprGhcRns` and `RebindableSyntax` machinery.
+This is very similar to:
+ 1. Expansions done in `GHC.Rename.Expr.rnHsIf` for expanding `HsIf`; and
+ 2. `desugarRecordUpd` in `GHC.Tc.Gen.Expr.tcExpr` for expanding `RecordUpd`
+See Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
+
+To disabmiguate desugaring (`HsExpr GhcTc -> Core.Expr`) we use the phrase expansion
+(`HsExpr GhcRn -> HsExpr GhcRn`)
+
+This expansion is done right before typechecking and after renaming
+See Part 2. of Note [Doing XXExprGhcRn in the Renamer vs Typechecker] in `GHC.Rename.Expr`
+
+Historical note START
+---------------------
+In previous versions of GHC, the `do`-notation wasn't expanded before typechecking,
+instead the typechecker would operate directly on the original.
+Why? because it ensured that type error messages were explained in terms of
+what the programmer has written. In practice, however, this didn't work very well:
+
+* Attempts to typecheck the original source code turned out to be buggy, and virtually impossible
+ to fix (#14963, #15598, #21206 and others)
+
+* The typechecker expected the `>>=` operator to have a type that matches
+ `m _ -> (_ -> m _) -> m _` for some `m`. With `RebindableSyntax` or
+ `QualifiedDo` the `>>=` operator might not have the
+ standard type. It might have a type like
+
+ (>>=) :: Wombat m => m a1 a2 b -> (b -> m a2 a3 c) -> m a1 a3 c
+
+ Typechecking the term `(>>=) e1 (\x -> e2)` deals with all of this automatically.
+
+* With `ImpredicativeTypes` the programmer will expect Quick Look to instantiate
+ the quantifiers impredicatively (#18324). Again, that happens automatically if
+ you typecheck the expanded expression.
+
+Historical note END
+-------------------
+
+Do Expansions Equationally
+--------------------------
+We have the following schema for expanding `do`-statements.
+They capture the essence of statement expansions as implemented in `expand_do_stmts`
+
+ DO〠_ 】 maps a sequence of do statements and recursively converts them into expressions
+
+ (1) DO〠s; ss 】 = ‹ExpansionStmt s›((>>) s (‹PopErrCtxt›DO〠ss 】))
+
+ (2) DO〠p <- e; ss 】 = if p is irrefutable
+ then ‹ExpansionStmt (p <- e)›
+ (>>=) s (‹PopExprCtxt›(\ p -> DO〠ss 】))
+ else ‹ExpansionStmt (p <- e)›
+ (>>=) s (‹PopExprCtxt›(\case p -> DO〠ss 】
+ _ -> fail "pattern p failure"))
+
+ (3) DO〠let x = e; ss 】
+ = ‹ExpansionStmt (let x = e)› (let x = e in (‹PopErrCtxt›DO〠ss 】))
+
+
+ (4) DO〠rec ss; sss 】
+ = (>>=) e (\vars -> ‹PopErrCtxt›DO〠sss 】))
+ where (vars, e) = RECDO〠ss 】
+
+ (5) DO〠s 】 = s
+
+ RECDO〠_ 】 maps a sequence of recursively dependent monadic statements and converts it into an expression paired
+ with the variables that the rec finds a fix point of.
+
+ (6) RECDO〠ss 】 = (vars, mfix (\~vars -> (>>=) (DO〠ss 】) (return vars)))
+ where vars are all the variables free in ss
+
+
+For a concrete example, consider a `do`-block written by the user
+
+ f = {l0} do {l1} {pl}p <- {l1'} e1
+ {l2} g p
+ {l3} return {l3'} p
+
+The expanded version (performed by `expand_do_stmts`) looks like:
+
+ f = {g1} (>>=) ({l1'} e1) (\ {pl}p ->
+ {g2} (>>) ({l2} g p)
+ ({l3} return p))
+
+The {l1} etc are location/source span information stored in the AST by the parser,
+{g1} are compiler generated source spans.
+
+
+The 3 non-obvious points to consider are:
+ 1. Wrap the expression with a `fail` block if the pattern match is not irrefutable.
+ See Part 1. below
+ 2. Generate appropriate warnings for discarded results in a body statement
+ eg. say `do { .. ; (g p :: m Int) ; ... }`
+ See Part 2. below
+ 3. Generating appropriate type error messages which blame the correct source spans
+ See Part 3. below
+
+Part 1. Expanding Patterns Bindings
+-----------------------------------
+If `p` is a failable pattern---checked by `GHC.Tc.Gen.Pat.isIrrefutableHsPatRnTcM`---
+we need to wrap it with a `fail`-block. See Equation (2) above.
+
+The expansion of the `do`-block
+
+ do { Just p <- e1; e2 }
+
+(ignoring the location information) will be
+
+ (>>=) (e1)
+ (\case -- anonymous continuation lambda
+ Just p -> e2
+ _ -> fail "failable pattern p at location")
+
+The `fail`-block wrapping is done by `GHC.Tc.Gen.Do.mk_failable_expr`.
+
+* Note the explicit call to `fail`, in the monad of the `do`-block. Part of the specification
+ of do-notation is that if the pattern match fails, we fail in the monad, *not* just crash
+ at runtime.
+
+* That call of `fail` will (rightly) automatically generate a `MonadFail` constraint. So if the
+ pattern is irrefuable, we don't want to generate that `fail` alternative, else we'll generate
+ a `MonadFail` constraint that isn't needed.
+
+* _Wrinkle 1_: For pattern synonyms, we always wrap it with a `fail`-block.
+ When the pattern is irrefutable, we do not add the fail block.
+ This is important because the occurrence of `fail` means that the typechecker
+ will generate a `MonadFail` constraint, and the language spec says that
+ we should not do that for irrefutable patterns.
+
+ Note that pattern synonyms count as refutable (see `isIrrefutableHsPat`), and hence will generate
+ a `MonadFail` constraint, also, we would get a pattern match checker's redundant pattern warnings.
+ because after desugaring, it is marked as irrefutable! To avoid such
+ spurious warnings and type checker errors, we filter out those patterns that appear
+ in a do expansion generated match in `HsToCore.Match.matchWrapper`. (see testcase Typeable1.hs)
+
+* _Wrinkle 2_: The call to `fail` will give rise to a `MonadFail` constraint. What `CtOrigin` do we
+ attach to that constraint? It should be a good one, because it'll show up in error
+ messages when the `MonadFail` constraint can't be solved. Ideally, it should identify the
+ pattern `p`. Hence, we wrap the `fail` alternative expression with a `ExpandedPat`
+ that tags the fail expression with the failable pattern. (See testcase MonadFailErrors.hs)
+
+Part 2. Generate warnings for discarded body statement results
+--------------------------------------------------------------
+If the `do`-blocks' body statement is an expression that returns a
+value that is not of type `()`, we need to warn the user about discarded
+the value when `-Wunused-binds` flag is turned on. (See testcase T3263-2.hs)
+
+For example the `do`-block
+
+ do { e1; e2 } -- where, e1 :: m Int
+
+expands to
+
+ (>>) e1 e2
+
+* If `e1` returns a non-() value we want to emit a warning, telling the user that they
+ are discarding the value returned by e1. This is done by `HsToCore.dsExpr` in the `HsApp`
+ with a call to `HsToCore.warnUnusedBindValue`.
+
+* The decision to trigger the warning is: if the function is a compiler generated `(>>)`,
+ and its first argument `e1` has a non-() type
+
+Part 3. Blaming Offending Source Code and Generating Appropriate Error Messages
+-------------------------------------------------------------------------------
+To ensure we correctly track source of the offending user written source code,
+in this case the `do`-statement, we need to keep track of
+which source statement's expansion the typechecker is currently typechecking.
+For this purpose we use the `XXExprGhcRn.ExpansionRn`.
+It stores the original statement (with location) and the expanded expression
+
+ A. Expanding Body Statements
+ -----------------------------
+ For example, the `do`-block
+
+ do { e1; e2; e3 }
+
+ expands (ignoring the location info) to
+
+ ‹ExpandedThingRn do { e1; e2; e3 }› -- Original Do Expression
+ -- Expanded Do Expression
+ (‹ExpandedThingRn e1› -- Original Statement
+ ({(>>) e1} -- Expanded Expression
+ ‹PopErrCtxt› (‹ExpandedThingRn e2›
+ ({(>>) e2}
+ ‹PopErrCtxt› (‹ExpandedThingRn e3› {e3})))))
+
+ * Whenever the typechecker steps through an `ExpandedThingRn`,
+ we push the original statement in the error context, set the error location to the
+ location of the statement, and then typecheck the expanded expression.
+ This is similar to vanilla `XXExprGhcRn` and rebindable syntax
+ See Note [Rebindable syntax and XXExprGhcRn] in `GHC.Hs.Expr`.
+
+ * Recall, that when a source function argument fails to typecheck,
+ we print an error message like "In the second argument of the function f..".
+ However, `(>>)` is generated thus, we don't want to display that to the user; it would be confusing.
+ But also, we do not want to completely ignore it as we do want to keep the error blame carets
+ as precise as possible, and not just blame the complete `do`-block.
+ Thus, when we typecheck the application `(>>) e1`, we push the "In the stmt of do block e1" with
+ the source location of `e1` in the error context stack as we walk inside an `ExpandedThingRn`.
+ See also Note [splitHsApps].
+
+ * After the expanded expression of a `do`-statement is typechecked
+ and before moving to the next statement of the `do`-block, we need to first pop the top
+ of the error context stack which contains the error message for
+ the previous statement: eg. "In the stmt of a do block: e1".
+ This is explicitly encoded in the expansion expression using
+ the `XXExprGhcRn.PopErrCtxt`. Whenever `GHC.Tc.Gen.Expr.tcExpr` (via `GHC.Tc.Gen.tcXExpr`)
+ sees a `PopErrCtxt` it calls `GHC.Tc.Utils.Monad.popErrCtxt` to pop of the top of error context stack.
+ See ‹PopErrCtxt› in the example above.
+ Without this popping business for error context stack,
+ if there is a type error in `e2`, we would get a spurious and confusing error message
+ which mentions "In the stmt of a do block e1" along with the message
+ "In the stmt of a do block e2".
+
+ B. Expanding Bind Statements
+ -----------------------------
+ A `do`-block with a bind statement:
+
+ do { p <- e1; e2 }
+
+ expands (ignoring the location information) to
+
+ ‹ExpandedThingRn do{ p <- e1; e2 }› -- Original Do Expression
+ --
+ (‹ExpandedThingRn (p <- e1)› -- Original Statement
+ (((>>=) e1) -- Expanded Expression
+ ‹PopErrCtxt› ((\ p -> ‹ExpandedThingRn (e2)› e2)))
+ )
+
+
+ However, the expansion lambda `(\p -> e2)` is special as it is generated from a `do`-stmt expansion
+ and if a type checker error occurs in the pattern `p` (which is source generated), we need to say
+ "in a pattern binding in a do block" and not "in the pattern of a lambda" (cf. Typeable1.hs).
+ We hence use a tag `GenReason` in `Ghc.Tc.Origin`. When typechecking a `HsLam` in `Tc.Gen.Expr.tcExpr`
+ the `match_ctxt` is set to a `StmtCtxt` if `GenOrigin` is a `DoExpansionOrigin`.
+-}
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 466766a53a1d97e6771def6946f96616682763b9..b63e0862af104f959b57e4f71f7a84fbbc4c6d49 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -53,7 +53,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, getUpdFieldLbls )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
@@ -193,7 +192,7 @@ tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- - HsAppType type applications
-- - ExprWithTySig (e :: type)
-- - HsRecSel overloaded record fields
--- - HsExpanded renamer expansions
+-- - ExpandedThingRn renamer/pre-typechecker expansions
-- - HsOpApp operator applications
-- - HsOverLit overloaded literals
-- These constructors are the union of
@@ -206,7 +205,8 @@ tcExpr e@(OpApp {}) res_ty = tcApp e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
tcExpr e@(HsRecSel {}) res_ty = tcApp e res_ty
-tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty
+
+tcExpr (XExpr e) res_ty = tcXExpr e res_ty
tcExpr e@(HsOverLit _ lit) res_ty
= do { mb_res <- tcShortCutLit lit res_ty
@@ -262,14 +262,12 @@ tcExpr e@(HsIPVar _ x) res_ty
origin = IPOccOrigin x
tcExpr e@(HsLam x lam_variant matches) res_ty
- = do { (wrap, matches') <- tcMatchLambda herald match_ctxt matches res_ty
+ = do { (wrap, matches') <- tcMatchLambda herald matches res_ty
; return (mkHsWrap wrap $ HsLam x lam_variant matches') }
where
- match_ctxt = MC { mc_what = LamAlt lam_variant, mc_body = tcBody }
herald = ExpectedFunTyLam lam_variant e
-
{-
************************************************************************
* *
@@ -354,7 +352,7 @@ tcExpr (HsLet x binds expr) res_ty
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
; return (HsLet x binds' (mkLHsWrap wrapper expr')) }
-tcExpr (HsCase x scrut matches) res_ty
+tcExpr (HsCase ctxt scrut matches) res_ty
= do { -- We used to typecheck the case alternatives first.
-- The case patterns tend to give good type info to use
-- when typechecking the scrutinee. For example
@@ -374,13 +372,9 @@ tcExpr (HsCase x scrut matches) res_ty
-- This design choice is discussed in #17790
; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut
- ; traceTc "HsCase" (ppr scrut_ty)
; hasFixedRuntimeRep_syntactic FRRCase scrut_ty
- ; (mult_co_wrap, matches') <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty
- ; return (HsCase x (mkLHsWrap mult_co_wrap scrut') matches') }
- where
- match_ctxt = MC { mc_what = x,
- mc_body = tcBody }
+ ; (mult_co_wrap, matches') <- tcMatchesCase tcBody (Scaled mult scrut_ty) matches res_ty
+ ; return (HsCase ctxt (mkLHsWrap mult_co_wrap scrut') matches') }
tcExpr (HsIf x pred b1 b2) res_ty
= do { pred' <- tcCheckMonoExpr pred boolTy
@@ -414,11 +408,11 @@ Not using 'sup' caused #23814.
-}
tcExpr (HsMultiIf _ alts) res_ty
- = do { (ues, alts') <- mapAndUnzipM (\alt -> tcCollectingUsage $ wrapLocMA (tcGRHS match_ctxt res_ty) alt) alts
+ = do { (ues, alts') <- mapAndUnzipM (\alt -> tcCollectingUsage $
+ wrapLocMA (tcGRHS IfAlt tcBody res_ty) alt) alts
; res_ty <- readExpType res_ty
; tcEmitBindingUsage (supUEs ues) -- See Note [MultiWayIf linearity checking]
; return (HsMultiIf res_ty alts') }
- where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
tcExpr (HsDo _ do_or_lc stmts) res_ty
= tcDoStmts do_or_lc stmts res_ty
@@ -522,7 +516,7 @@ tcExpr expr@(RecordCon { rcon_con = L loc con_name
where
orig = OccurrenceOf con_name
--- Record updates via dot syntax are replaced by desugared expressions
+-- Record updates via dot syntax are replaced by expanded expressions
-- in the renamer. See Note [Overview of record dot syntax] in
-- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here
-- and panic otherwise.
@@ -534,18 +528,18 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr
})
res_ty
= assert (notNull rbnds) $
- do { -- Desugar the record update. See Note [Record Updates].
+ do { -- Expand the record update. See Note [Record Updates].
; (ds_expr, ds_res_ty, err_ctxt)
- <- desugarRecordUpd record_expr possible_parents rbnds res_ty
+ <- expandRecordUpd record_expr possible_parents rbnds res_ty
- -- Typecheck the desugared expression.
+ -- Typecheck the expanded expression.
; expr' <- addErrCtxt err_ctxt $
tcExpr (mkExpandedExpr expr ds_expr) (Check ds_res_ty)
-- NB: it's important to use ds_res_ty and not res_ty here.
-- Test case: T18802b.
; addErrCtxt err_ctxt $ tcWrapResultMono expr expr' ds_res_ty res_ty
- -- We need to unify the result type of the desugared
+ -- We need to unify the result type of the expanded
-- expression with the expected result type.
--
-- See Note [Unifying result types in tcRecordUpd].
@@ -576,7 +570,7 @@ tcExpr (ArithSeq _ witness seq) res_ty
************************************************************************
-}
--- These terms have been replaced by desugaring in the renamer. See
+-- These terms have been replaced by their expanded expressions in the renamer. See
-- Note [Overview of record dot syntax].
tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
@@ -621,6 +615,45 @@ tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty)
tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
+{-
+************************************************************************
+* *
+ Expansion Expressions (XXExprGhcRn)
+* *
+************************************************************************
+-}
+
+tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+
+tcXExpr (PopErrCtxt (L loc e)) res_ty
+ = popErrCtxt $ -- See Part 3 of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
+ setSrcSpanA loc $
+ tcExpr e res_ty
+
+tcXExpr xe@(ExpandedThingRn o e') res_ty
+ | OrigStmt ls@(L loc s@LetStmt{}) <- o
+ , HsLet x binds e <- e'
+ = do { (binds', wrapper, e') <- setSrcSpanA loc $
+ addStmtCtxt s $
+ tcLocalBinds binds $
+ tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds
+ -- a duplicate error context
+ ; return $ mkExpandedStmtTc ls (HsLet x binds' (mkLHsWrap wrapper e'))
+ }
+ | OrigStmt ls@(L loc s@LastStmt{}) <- o
+ = setSrcSpanA loc $
+ addStmtCtxt s $
+ mkExpandedStmtTc ls <$> tcExpr e' res_ty
+ -- It is important that we call tcExpr (and not tcApp) here as
+ -- `e` is the last statement's body expression
+ -- and not a HsApp of a generated (>>) or (>>=)
+ -- This improves error messages e.g. tests: DoExpansion1, DoExpansion2, DoExpansion3
+ | OrigStmt ls@(L loc _) <- o
+ = setSrcSpanA loc $
+ mkExpandedStmtTc ls <$> tcApp (XExpr xe) res_ty
+
+tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
+
{-
************************************************************************
* *
@@ -939,19 +972,19 @@ in the other order, the extra signature in f2 is reqd.
{- *********************************************************************
* *
- Desugaring record update
+ Expanding record update
* *
********************************************************************* -}
{- Note [Record Updates]
~~~~~~~~~~~~~~~~~~~~~~~~
-To typecheck a record update, we desugar it first. Suppose we have
+To typecheck a record update, we expand it first. Suppose we have
data T p q = T1 { x :: Int, y :: Bool, z :: Char }
| T2 { v :: Char }
| T3 { x :: Int }
| T4 { p :: Float, y :: Bool, x :: Int }
| T5
-Then the record update `e { x=e1, y=e2 }` desugars as follows
+Then the record update `e { x=e1, y=e2 }` expands as follows
e { x=e1, y=e2 }
===>
@@ -960,7 +993,7 @@ Then the record update `e { x=e1, y=e2 }` desugars as follows
T1 _ _ z -> T1 x' y' z
T4 p _ _ -> T4 p y' x'
T2, T3 and T5 should not occur, so we omit them from the match.
-The critical part of desugaring is to identify T and then T1/T4.
+The critical part of expansion is to identify T and then T1/T4.
Wrinkle [Disambiguating fields]
@@ -975,17 +1008,17 @@ Wrinkle [Disambiguating fields]
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst.
-All in all, this means that when typechecking a record update via desugaring,
+All in all, this means that when typechecking a record update via expansion,
we take the following steps:
(0) Perform a first typechecking pass on the record expression (`e` in the example above),
to infer the type of the record being updated.
(1) Disambiguate the record fields (potentially using the type obtained in (0)).
- (2) Desugar the record update as described above, using an HsExpansion.
+ (2) Expand the record update as described above, using an XXExprGhcRn.
(a) Create a let-binding to share the record update right-hand sides.
- (b) Desugar the record update to a case expression updating all the
+ (b) Expand the record update to a case expression updating all the
relevant constructors (those that have all of the fields being updated).
- (3) Typecheck the desugared code.
+ (3) Typecheck the expanded code.
In (0), we call inferRho to infer the type of the record being updated. This returns the
inferred type of the record, together with a typechecked expression (of type HsExpr GhcTc)
@@ -1008,7 +1041,7 @@ Wrinkle [Using IdSig]
data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int }
foo r = r { f = \ k -> (k 3, k 'x') }
- If we desugar to:
+ If we expand to:
ds_foo r =
let f' = \ k -> (k 3, k 'x')
@@ -1074,7 +1107,7 @@ Record updates which require constraint-solving should instead use the
Note [Unifying result types in tcRecordUpd]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-After desugaring and typechecking a record update in the way described in
+After expanding and typechecking a record update in the way described in
Note [Record Updates], we must take care to unify the result types.
Example:
@@ -1085,7 +1118,7 @@ Example:
f :: F Int -> D Bool -> D Int
f i r = r { fld = i }
-This record update desugars to:
+This record update expands to:
let x :: F alpha -- metavariable
x = i
@@ -1119,13 +1152,13 @@ Wrinkle [GADT result type in tcRecordUpd]
-}
--- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2 }@ into a case expression
+-- | Expands a record update @record_expr { fld1 = e1, fld2 = e2 }@ into a case expression
-- that matches on the constructors of the record @r@, as described in
-- Note [Record Updates].
--
-- Returns a renamed but not-yet-typechecked expression, together with the
--- result type of this desugared record update.
-desugarRecordUpd :: LHsExpr GhcRn
+-- result type of this expanded record update.
+expandRecordUpd :: LHsExpr GhcRn
-- ^ @record_expr@: expression to which the record update is applied
-> NE.NonEmpty (HsRecUpdParent GhcRn)
-- ^ Possible parent 'TyCon'/'PatSyn's for the record update,
@@ -1135,19 +1168,19 @@ desugarRecordUpd :: LHsExpr GhcRn
-> ExpRhoType
-- ^ the expected result type of the record update
-> TcM ( HsExpr GhcRn
- -- desugared record update expression
+ -- Expanded record update expression
, TcType
- -- result type of desugared record update
+ -- result type of expanded record update
, SDoc
-- error context to push when typechecking
- -- the desugared code
+ -- the expanded code
)
-desugarRecordUpd record_expr possible_parents rbnds res_ty
+expandRecordUpd record_expr possible_parents rbnds res_ty
= do { -- STEP 0: typecheck the record_expr, the record to be updated.
--
-- Until GHC proposal #366 is implemented, we still use the type of
-- the record to disambiguate its fields, so we must infer the record
- -- type here before we can desugar. See Wrinkle [Disambiguating fields]
+ -- type here before we can expand. See Wrinkle [Disambiguating fields]
-- in Note [Record Updates].
; ((_, record_rho), _lie) <- captureConstraints $ -- see (1) below
tcScalingUsage ManyTy $ -- see (2) below
@@ -1157,7 +1190,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
-- Note that we capture, and then discard, the constraints.
-- This `tcInferRho` is used *only* to identify the data type,
-- so we can deal with field disambiguation.
- -- Then we are going to generate a desugared record update, including `record_expr`,
+ -- Then we are going to generate a expanded record update, including `record_expr`,
-- and typecheck it from scratch. We don't want to generate the constraints twice!
-- (2)
@@ -1187,7 +1220,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
relevant_cons = nonDetEltsUniqSet cons
relevant_con = head relevant_cons
- -- STEP 2: desugar the record update.
+ -- STEP 2: expand the record update.
--
-- (a) Create new variables for the fields we are updating,
-- so that we can share them across constructors.
@@ -1262,7 +1295,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
updEnv = listToUniqMap $ upd_ids
make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn)
- -- As explained in Note [Record Updates], to desugar
+ -- As explained in Note [Record Updates], to expand
--
-- e { x=e1, y=e2 }
--
@@ -1275,7 +1308,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
-- we let-bind x' = e1, y' = e2 and generate the equation:
--
-- T1 _ _ z -> T1 x' y' z
- make_pat conLike = mkSimpleMatch CaseAlt [pat] rhs
+ make_pat conLike = mkSimpleMatch RecUpd [pat] rhs
where
(lhs_con_pats, rhs_con_args)
= zipWithAndUnzip mk_con_arg [1..] con_fields
@@ -1291,7 +1324,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
, LHsExpr GhcRn )
-- RHS constructor argument
mk_con_arg i fld_lbl =
- -- The following generates the pattern matches of the desugared `case` expression.
+ -- The following generates the pattern matches of the expanded `case` expression.
-- For fields being updated (for example `x`, `y` in T1 and T4 in Note [Record Updates]),
-- wildcards are used to avoid creating unused variables.
case lookupUniqMap updEnv $ flSelector fld_lbl of
@@ -1303,13 +1336,13 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
generatedSrcSpan
in (genVarPat fld_nm, genLHsVar fld_nm)
- -- STEP 2 (b): desugar to HsCase, as per note [Record Updates]
+ -- STEP 2 (b): expand to HsCase, as per note [Record Updates]
; let ds_expr :: HsExpr GhcRn
ds_expr = HsLet noExtField let_binds (L gen case_expr)
case_expr :: HsExpr GhcRn
case_expr = HsCase RecUpd record_expr
- $ mkMatchGroup (Generated DoPmc) (wrapGenSpan matches)
+ $ mkMatchGroup (Generated OtherExpansion DoPmc) (wrapGenSpan matches)
matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches = map make_pat relevant_cons
@@ -1326,7 +1359,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
-- See Wrinkle [Using IdSig] in Note [Record Updates].
gen = noAnnSrcSpan generatedSrcSpan
- ; traceTc "desugarRecordUpd" $
+ ; traceTc "expandRecordUpd" $
vcat [ text "relevant_con:" <+> ppr relevant_con
, text "res_ty:" <+> ppr res_ty
, text "ds_res_ty:" <+> ppr ds_res_ty
@@ -1562,7 +1595,7 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
-- Yuk: the field_id has the *unique* of the selector Id
-- (so we can find it easily)
-- but is a LocalId with the appropriate type of the RHS
- -- (so the desugarer knows the type of local binder to make)
+ -- (so the expansion knows the type of local binder to make)
; return (Just (L loc (FieldOcc field_id lbl), rhs')) }
| otherwise
= do { addErrTc (badFieldConErr (getName con_like) field_lbl)
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 8a8ff0c31652216ba719b65120fefebf5940a928..02157ffa7bfce19be0b1b64575b7e48efa98a8a7 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -28,7 +28,7 @@ module GHC.Tc.Gen.Head
, tyConOf, tyConOfET, fieldNotInType
, nonBidirectionalErr
- , addHeadCtxt, addExprCtxt, addFunResCtxt ) where
+ , addHeadCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )
@@ -156,7 +156,7 @@ takes apart either an HsApp, or an infix OpApp, returning
* The "user head" or "error head" of the application, to be reported to the
user in case of an error. Example:
(`op` e)
- expands (via HsExpanded) to
+ expands (via ExpandedThingRn) to
(rightSection op e)
but we don't want to see 'rightSection' in error messages. So we keep the
innermost un-expanded head as the "error head".
@@ -184,7 +184,7 @@ data HsExprArg (p :: TcPass)
| EWrap EWrap
data EWrap = EPar AppCtxt
- | EExpand (HsExpr GhcRn)
+ | EExpand HsThingRn
| EHsWrap HsWrapper
data EValArg (p :: TcPass) where -- See Note [EValArg]
@@ -201,13 +201,9 @@ data EValArg (p :: TcPass) where -- See Note [EValArg]
data AppCtxt
= VAExpansion
- (HsExpr GhcRn) -- Inside an expansion of this expression
- SrcSpan -- The SrcSpan of the expression
- -- noSrcSpan if outermost; see Note [AppCtxt]
- SrcSpan -- The SrcSpan of the application as specified
- -- inside the expansion.
- -- Used for accurately reconstructing the
- -- original SrcSpans in 'rebuildHsApps'.
+ HsThingRn
+ SrcSpan
+ SrcSpan
| VACall
(HsExpr GhcRn) Int -- In the third argument of function f
@@ -247,11 +243,11 @@ appCtxtLoc (VACall _ _ l) = l
insideExpansion :: AppCtxt -> Bool
insideExpansion (VAExpansion {}) = True
-insideExpansion (VACall {}) = False
+insideExpansion (VACall {}) = False -- but what if the VACall has a generated context?
instance Outputable AppCtxt where
- ppr (VAExpansion e _ _) = text "VAExpansion" <+> ppr e
- ppr (VACall f n _) = text "VACall" <+> int n <+> ppr f
+ ppr (VAExpansion e l _) = text "VAExpansion" <+> ppr e <+> ppr l
+ ppr (VACall f n l) = text "VACall" <+> int n <+> ppr f <+> ppr l
type family XPass p where
XPass 'TcpRn = 'Renamed
@@ -299,7 +295,8 @@ splitHsApps e = go e (top_ctxt 0 e) []
top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun
top_ctxt n (HsAppType _ fun _) = top_lctxt (n+1) fun
top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun
- top_ctxt n (XExpr (HsExpanded orig _)) = VACall orig n noSrcSpan
+ top_ctxt n (XExpr (ExpandedThingRn o _))
+ | OrigExpr fun <- o = VACall fun n noSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
top_lctxt n (L _ fun) = top_ctxt n fun
@@ -312,17 +309,12 @@ splitHsApps e = go e (top_ctxt 0 e) []
go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty : args)
go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args)
- -- See Note [Looking through HsExpanded]
- go (XExpr (HsExpanded orig fun)) ctxt args
- = go fun (VAExpansion orig (appCtxtLoc ctxt) (appCtxtLoc ctxt))
- (EWrap (EExpand orig) : args)
-
-- See Note [Looking through Template Haskell splices in splitHsApps]
go e@(HsUntypedSplice splice_res splice) ctxt args
= case splice_res of
HsUntypedSpliceTop mod_finalizers fun
-> do addModFinalizersWithLclEnv mod_finalizers
- go fun ctxt' (EWrap (EExpand e) : args)
+ go fun ctxt' (EWrap (EExpand (OrigExpr e)) : args)
HsUntypedSpliceNested {} -> panic "splitHsApps: invalid nested splice"
where
ctxt' :: AppCtxt
@@ -331,22 +323,45 @@ splitHsApps e = go e (top_ctxt 0 e) []
HsUntypedSpliceExpr _ (L l _) -> set l ctxt -- l :: SrcAnn AnnListItem
HsQuasiQuote _ _ (L l _) -> set l ctxt -- l :: SrcAnn NoEpAnns
+ -- See Note [Looking through ExpandedThingRn]
+ go (XExpr (ExpandedThingRn o e)) ctxt args
+ | isHsThingRnExpr o
+ = go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
+ (EWrap (EExpand o) : args)
+
+ | OrigStmt (L _ stmt) <- o -- so that we set `(>>)` as generated
+ , BodyStmt{} <- stmt -- and get the right unused bind warnings
+ = go e (VAExpansion o generatedSrcSpan generatedSrcSpan)
+ -- See Part 3. in Note [Expanding HsDo with XXExprGhcRn]
+ (EWrap (EExpand o) : args) -- in `GHC.Tc.Gen.Do`
+
+
+ | OrigPat (L loc _) <- o -- so that we set the compiler generated fail context
+ = go e (VAExpansion o (locA loc) (locA loc)) -- to be originating from a failable pattern
+ -- See Part 1. Wrinkle 2. of
+ (EWrap (EExpand o) : args) -- Note [Expanding HsDo with XXExprGhcRn]
+ -- in `GHC.Tc.Gen.Do`
+
+ | otherwise
+ = go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
+ (EWrap (EExpand o) : args)
+
-- See Note [Desugar OpApp in the typechecker]
go e@(OpApp _ arg1 (L l op) arg2) _ args
= pure ( (op, VACall op 0 (locA l))
, mkEValArg (VACall op 1 generatedSrcSpan) arg1
: mkEValArg (VACall op 2 generatedSrcSpan) arg2
- : EWrap (EExpand e)
+ : EWrap (EExpand (OrigExpr e))
: args )
go e ctxt args = pure ((e,ctxt), args)
set :: EpAnn ann -> AppCtxt -> AppCtxt
- set l (VACall f n _) = VACall f n (locA l)
+ set l (VACall f n _) = VACall f n (locA l)
set l (VAExpansion orig ol _) = VAExpansion orig ol (locA l)
dec :: EpAnn ann -> AppCtxt -> AppCtxt
- dec l (VACall f n _) = VACall f (n-1) (locA l)
+ dec l (VACall f n _) = VACall f (n-1) (locA l)
dec l (VAExpansion orig ol _) = VAExpansion orig ol (locA l)
-- | Rebuild an application: takes a type-checked application head
@@ -390,7 +405,10 @@ rebuild_hs_apps fun ctxt (arg : args)
EWrap (EPar ctxt')
-> rebuild_hs_apps (gHsPar lfun) ctxt' args
EWrap (EExpand orig)
- -> rebuild_hs_apps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args
+ | OrigExpr oe <- orig
+ -> rebuild_hs_apps (mkExpandedExprTc oe fun) ctxt args
+ | otherwise
+ -> rebuild_hs_apps fun ctxt args
EWrap (EHsWrap wrap)
-> rebuild_hs_apps (mkHsWrap wrap fun) ctxt args
where
@@ -765,25 +783,25 @@ pprHsExprArgTc arg = ppr arg
Operator sections are desugared in the renamer; see GHC.Rename.Expr
Note [Handling overloaded and rebindable constructs].
But for reasons explained there, we rename OpApp to OpApp. Then,
-here in the typechecker, we desugar it to a use of HsExpanded.
+here in the typechecker, we desugar it to a use of ExpandedThingRn.
That makes it possible to typecheck something like
e1 `f` e2
where
f :: forall a. t1 -> forall b. t2 -> t3
-Note [Looking through HsExpanded]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Looking through ExpandedThingRn]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When creating an application chain in splitHsApps, we must deal with
- HsExpanded f1 (f `HsApp` e1) `HsApp` e2 `HsApp` e3
+ ExpandedThingRn f1 (f `HsApp` e1) `HsApp` e2 `HsApp` e3
as a single application chain `f e1 e2 e3`. Otherwise stuff like overloaded
labels (#19154) won't work.
-It's easy to achieve this: `splitHsApps` unwraps `HsExpanded`.
+It's easy to achieve this: `splitHsApps` unwraps `ExpandedThingRn`.
In order to be able to more accurately reconstruct the original `SrcSpan`s
from the renamer in `rebuildHsApps`, we also have to track the `SrcSpan`
-of the current application in `VAExpansion` when unwrapping `HsExpanded`
+of the current application in `VAExpansion` when unwrapping `ExpandedThingRn`
in `splitHsApps`, just as we track it in a non-expanded expression.
Previously, `rebuildHsApps` substituted the location of the original
@@ -882,17 +900,22 @@ tcInferAppHead_maybe fun
_ -> return Nothing
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
+addHeadCtxt (VAExpansion (OrigStmt (L loc stmt)) _ _) thing_inside =
+ do setSrcSpanA loc $
+ addStmtCtxt stmt
+ thing_inside
addHeadCtxt fun_ctxt thing_inside
| not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
= thing_inside -- => context is already set
| otherwise
= setSrcSpan fun_loc $
- case fun_ctxt of
- VAExpansion orig _ _ -> addExprCtxt orig thing_inside
- VACall {} -> thing_inside
+ do case fun_ctxt of
+ VAExpansion (OrigExpr orig) _ _ -> addExprCtxt orig thing_inside
+ _ -> thing_inside
where
fun_loc = appCtxtLoc fun_ctxt
+
{- *********************************************************************
* *
Record selectors
@@ -1611,6 +1634,17 @@ mis-match in the number of value arguments.
* *
********************************************************************* -}
+addStmtCtxt :: ExprStmt GhcRn -> TcRn a -> TcRn a
+addStmtCtxt stmt thing_inside
+ = do let err_doc = pprStmtInCtxt (HsDoStmt (DoExpr Nothing)) stmt
+ addErrCtxt err_doc thing_inside
+ where
+ pprStmtInCtxt :: HsStmtContext GhcRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
+ pprStmtInCtxt ctxt stmt
+ = vcat [ hang (text "In a stmt of"
+ <+> pprAStmtContext ctxt <> colon) 2 (pprStmt stmt)
+ ]
+
addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 28be511a81c9c0b707d09c09892ec73b5cfec525..d216e80e3336ce588df2723a472a2868746c4eaf 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -21,7 +21,7 @@ module GHC.Tc.Gen.Match
, tcGRHSsPat
, tcMatchesCase
, tcMatchLambda
- , TcMatchCtxt(..)
+ , TcMatchAltChecker
, TcStmtChecker
, TcExprStmtChecker
, TcCmdStmtChecker
@@ -42,11 +42,12 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC
, tcCheckMonoExpr, tcCheckMonoExprNC
, tcCheckPolyExpr )
-import GHC.Rename.Utils ( bindLocalNames, isIrrefutableHsPatRn )
+import GHC.Rename.Utils ( bindLocalNames, isIrrefutableHsPat )
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Pat
+import GHC.Tc.Gen.Do
import GHC.Tc.Gen.Head( tcCheckId )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
@@ -59,7 +60,7 @@ import GHC.Tc.Types.Evidence
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Core.TyCon
--- Create chunkified tuple tybes for monad comprehensions
+-- Create chunkified tuple types for monad comprehensions
import GHC.Core.Make
import GHC.Hs
@@ -76,12 +77,16 @@ import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.SrcLoc
+import GHC.Types.Basic
import Control.Monad
import Control.Arrow ( second )
import qualified Data.List.NonEmpty as NE
import Data.Maybe (mapMaybe)
+import qualified GHC.LanguageExtensions as LangExt
+
+
{-
************************************************************************
* *
@@ -109,7 +114,7 @@ tcMatchesFun fun_name mult matches exp_ty
-- ann-grabbing, because we don't always have annotations in
-- hand when we call tcMatchesFun...
traceTc "tcMatchesFun" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity)
- ; checkArgCounts what matches
+ ; checkArgCounts (Just what) matches
; (wrapper, (mult_co_wrap, r)) <- matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->
-- NB: exp_type may be polymorphic, but
@@ -117,7 +122,7 @@ tcMatchesFun fun_name mult matches exp_ty
tcScalingUsage mult $
-- Makes sure that if the binding is unrestricted, it counts as
-- consuming its rhs Many times.
- tcMatches match_ctxt pat_tys rhs_ty matches
+ tcMatches tcBody pat_tys rhs_ty matches
; return (wrapper <.> mult_co_wrap, r) }
where
arity = matchGroupArity matches
@@ -125,7 +130,6 @@ tcMatchesFun fun_name mult matches exp_ty
ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True
-- But that's wrong for f :: Int -> forall a. blah
what = FunRhs { mc_fun = fun_name, mc_fixity = Prefix, mc_strictness = strictness }
- match_ctxt = MC { mc_what = what, mc_body = tcBody }
strictness
| [L _ match] <- unLoc $ mg_alts matches
, FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match
@@ -139,7 +143,7 @@ parser guarantees that each equation has exactly one argument.
-}
tcMatchesCase :: (AnnoBody body, Outputable (body GhcTc)) =>
- TcMatchCtxt body -- ^ Case context
+ TcMatchAltChecker body -- ^ Case context
-> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee
-> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives
-> ExpRhoType -- ^ Type of the whole case expression
@@ -151,20 +155,27 @@ tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty
= tcMatches ctxt [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches
tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify
- -> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-tcMatchLambda herald match_ctxt match res_ty
- = do { checkArgCounts (mc_what match_ctxt) match
+tcMatchLambda herald match res_ty
+ = do { checkArgCounts Nothing match
; (wrapper, (mult_co_wrap, r)) <- matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty ->
-- checking argument counts since this is also used for \cases
- tcMatches match_ctxt pat_tys rhs_ty match
+ tcMatches match_alt_checker pat_tys rhs_ty match
; return (wrapper <.> mult_co_wrap, r) }
where
n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case
| otherwise = matchGroupArity match
+ match_alt_checker
+ | isDoExpansionGenerated (mg_ext match)
+ -- See Part 3. B. of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`. Testcase: Typeable1
+ = tcBodyNC -- NB: Do not add any error contexts
+ -- It has already been done
+ | otherwise
+ = tcBody
+
-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType
@@ -172,13 +183,9 @@ tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType
-- Used for pattern bindings
tcGRHSsPat mult grhss res_ty
= tcScalingUsage mult $ do
- { (mult_co_wrapper, r) <- tcGRHSs match_ctxt grhss res_ty
+ { (mult_co_wrapper, r) <- tcGRHSs PatBindRhs tcBody grhss res_ty
; return $ mkWrap mult_co_wrapper r }
where
- match_ctxt :: TcMatchCtxt HsExpr -- AZ
- match_ctxt = MC { mc_what = PatBindRhs,
- mc_body = tcBody }
-
mkWrap wrap grhss@(GRHSs { grhssGRHSs = L loc (GRHS x guards body) : rhss }) =
grhss { grhssGRHSs = L loc (GRHS x guards (mkLHsWrap wrap body)) : rhss }
mkWrap _ (GRHSs { grhssGRHSs = [] }) = panic "tcGRHSsPat: empty GHRSs"
@@ -195,12 +202,11 @@ tcGRHSsPat mult grhss res_ty
* *
********************************************************************* -}
-data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module
- = MC { mc_what :: HsMatchContext GhcTc, -- What kind of thing this is
- mc_body :: LocatedA (body GhcRn) -- Type checker for a body of
- -- an alternative
- -> ExpRhoType
- -> TcM (LocatedA (body GhcTc)) }
+-- | Type checker for a body of a match alternative
+type TcMatchAltChecker body
+ = LocatedA (body GhcRn)
+ -> ExpRhoType
+ -> TcM (LocatedA (body GhcTc))
type AnnoBody body
= ( Outputable (body GhcRn)
@@ -216,7 +222,7 @@ type AnnoBody body
-- | Type-check a MatchGroup.
tcMatches :: (AnnoBody body, Outputable (body GhcTc)) =>
- TcMatchCtxt body
+ TcMatchAltChecker body
-> [ExpPatType] -- ^ Expected pattern types.
-> ExpRhoType -- ^ Expected result-type of the Match.
-> MatchGroup GhcRn (LocatedA (body GhcRn))
@@ -256,34 +262,35 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
match_fun_pat_ty ExpForAllPatTy{} = Nothing
-------------
-tcMatch :: (AnnoBody body) => TcMatchCtxt body
+tcMatch :: (AnnoBody body) => TcMatchAltChecker body
-> [ExpPatType] -- Expected pattern types
-> ExpRhoType -- Expected result-type of the Match.
-> LMatch GhcRn (LocatedA (body GhcRn))
-> TcM (HsWrapper, LMatch GhcTc (LocatedA (body GhcTc)))
-tcMatch ctxt pat_tys rhs_ty match
- = do { (L loc (wrapper, r)) <- wrapLocMA (tc_match ctxt pat_tys rhs_ty) match
+tcMatch alt_checker pat_tys rhs_ty match
+ = do { (L loc (wrapper, r)) <- wrapLocMA (tc_match alt_checker pat_tys rhs_ty) match
; return (wrapper, L loc r) }
where
- tc_match ctxt pat_tys rhs_ty
- match@(Match { m_pats = pats, m_grhss = grhss })
+ tc_match match_alt_checker pat_tys rhs_ty
+ match@(Match { m_ctxt = ctxt, m_pats = pats, m_grhss = grhss })
= add_match_ctxt match $
- do { (pats', (wrapper, grhss')) <- tcPats (mc_what ctxt) pats pat_tys $
- tcGRHSs ctxt grhss rhs_ty
+ do { (pats', (wrapper, grhss')) <- tcPats ctxt' pats pat_tys $
+ tcGRHSs ctxt' match_alt_checker grhss rhs_ty
; return (wrapper, Match { m_ext = noAnn
- , m_ctxt = mc_what ctxt
+ , m_ctxt = ctxt'
, m_pats = filter_out_type_pats pats'
, m_grhss = grhss' }) }
-
+ where ctxt' = convertHsMatchCtxt ctxt
-- For (\x -> e), tcExpr has already said "In the expression \x->e"
-- so we don't want to add "In the lambda abstraction \x->e"
-- But for \cases with many alternatives, it is helpful to say
-- which particular alternative we are looking at
add_match_ctxt match thing_inside
- = case mc_what ctxt of
+ = case (m_ctxt match) of
LamAlt LamSingle -> thing_inside
- _ -> addErrCtxt (pprMatchInCtxt match) thing_inside
+ StmtCtxt (HsDoStmt{}) -> thing_inside -- this is an expanded do stmt
+ _ -> addErrCtxt (pprMatchInCtxt match) thing_inside
-- We filter out type patterns because we have no use for them in HsToCore.
-- Type variable bindings have already been converted to HsWrappers.
@@ -293,37 +300,60 @@ tcMatch ctxt pat_tys rhs_ty match
is_fun_pat_ty ExpFunPatTy{} = True
is_fun_pat_ty ExpForAllPatTy{} = False
+
+-- | Ths function converts HsMatchContext GhcRn to HsMatchContext GhcTc
+-- It is a little silly to do it this way as all except for FunRhs constructor, are independent
+-- of the GhcPass index parameter.
+convertHsMatchCtxt :: HsMatchContext GhcRn -> HsMatchContext GhcTc
+convertHsStmtCtxt :: HsStmtContext GhcRn -> HsStmtContext GhcTc
+
+convertHsMatchCtxt CaseAlt = CaseAlt
+convertHsMatchCtxt (LamAlt x) = LamAlt x
+convertHsMatchCtxt IfAlt = IfAlt
+convertHsMatchCtxt (ArrowMatchCtxt x) = ArrowMatchCtxt x
+convertHsMatchCtxt PatBindRhs = PatBindRhs
+convertHsMatchCtxt LazyPatCtx = LazyPatCtx
+convertHsMatchCtxt PatBindGuards = CaseAlt
+convertHsMatchCtxt RecUpd = RecUpd
+convertHsMatchCtxt (StmtCtxt x) = StmtCtxt $ convertHsStmtCtxt x
+convertHsMatchCtxt ThPatSplice = ThPatSplice
+convertHsMatchCtxt ThPatQuote = ThPatQuote
+convertHsMatchCtxt PatSyn = PatSyn
+convertHsMatchCtxt (FunRhs x y z) = FunRhs x y z
+
+convertHsStmtCtxt (HsDoStmt x) = HsDoStmt x
+convertHsStmtCtxt (PatGuard x) = PatGuard $ convertHsMatchCtxt x
+convertHsStmtCtxt (ParStmtCtxt x) = ParStmtCtxt $ convertHsStmtCtxt x
+convertHsStmtCtxt (TransStmtCtxt x) = TransStmtCtxt $ convertHsStmtCtxt x
+convertHsStmtCtxt ArrowExpr = ArrowExpr
+
-------------
tcGRHSs :: AnnoBody body
- => TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
+ => HsMatchContext GhcTc -> TcMatchAltChecker body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
-> TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
-
-- Notice that we pass in the full res_ty, so that we get
-- good inference from simple things like
-- f = \(x::forall a.a->a) -> <stuff>
-- We used to force it to be a monotype when there was more than one guard
-- but we don't need to do that any more
-
-tcGRHSs ctxt (GRHSs _ grhss binds) res_ty
+tcGRHSs ctxt alt_checker (GRHSs _ grhss binds) res_ty
= do { (binds', wrapper, grhss')
<- tcLocalBinds binds $ do
- { ugrhss <- mapM (tcCollectingUsage . wrapLocMA (tcGRHS ctxt res_ty)) grhss
+ { ugrhss <- mapM (tcCollectingUsage . wrapLocMA (tcGRHS ctxt alt_checker res_ty)) grhss
; let (usages, grhss') = unzip ugrhss
; tcEmitBindingUsage $ supUEs usages
; return grhss' }
; return (wrapper, GRHSs emptyComments grhss' binds') }
-
-------------
-tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn))
+tcGRHS :: HsMatchContext GhcTc -> TcMatchAltChecker body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
-
-tcGRHS ctxt res_ty (GRHS _ guards rhs)
+tcGRHS ctxt alt_checker res_ty (GRHS _ guards rhs)
= do { (guards', rhs')
<- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
- mc_body ctxt rhs
+ alt_checker rhs
; return (GRHS noAnn guards' rhs') }
where
- stmt_ctxt = PatGuard (mc_what ctxt)
+ stmt_ctxt = PatGuard ctxt
{-
************************************************************************
@@ -345,10 +375,16 @@ tcDoStmts ListComp (L l stmts) res_ty
(mkCheckExpType elt_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')) }
+tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty
+ = do { isApplicativeDo <- xoptM LangExt.ApplicativeDo
+ ; if isApplicativeDo
+ then do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
+ ; res_ty <- readExpType res_ty
+ ; return (HsDo res_ty doExpr (L l stmts')) }
+ else do { expanded_expr <- expandDoStmts doExpr stmts
+ -- Do expansion on the fly
+ ; mkExpandedExprTc (HsDo noExtField doExpr ss) <$> tcExpr (unLoc expanded_expr) res_ty }
+ }
tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty
= do { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
@@ -367,6 +403,12 @@ tcBody body res_ty
; tcMonoExpr body res_ty
}
+tcBodyNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
+tcBodyNC body res_ty
+ = do { traceTc "tcBodyNC" (ppr res_ty)
+ ; tcMonoExprNC body res_ty
+ }
+
{-
************************************************************************
* *
@@ -887,7 +929,6 @@ 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) }
-
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
@@ -926,7 +967,6 @@ 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) }
-
tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
= do { -- Deal with rebindable syntax;
-- (>>) :: rhs_ty -> new_res_ty -> res_ty
@@ -939,7 +979,6 @@ 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) }
-
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 })
@@ -1018,7 +1057,7 @@ tcMonadFailOp :: CtOrigin
-- yet determined.
tcMonadFailOp orig pat fail_op res_ty = do
dflags <- getDynFlags
- if isIrrefutableHsPatRn dflags pat
+ if isIrrefutableHsPat dflags pat
then return Nothing
else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
(mkCheckExpType res_ty) $ \_ _ -> return ())
@@ -1186,21 +1225,25 @@ the variables they bind into scope, and typecheck the thing_inside.
-- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same
-- number of args are used in each equation.
checkArgCounts :: AnnoBody body
- => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))
+ => Maybe (HsMatchContext GhcTc)
+ -> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM ()
checkArgCounts _ (MG { mg_alts = L _ [] })
= return ()
-checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
+checkArgCounts mb_ctxt (MG { mg_alts = L _ (match1:matches) })
| null matches -- There was only one match; nothing to check
= return ()
-- Two or more matches: check that they agree on arity
| Just bad_matches <- mb_bad_matches
- = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext
+ = failWithTc $ TcRnMatchesHaveDiffNumArgs ctxt
$ MatchArgMatches match1 bad_matches
| otherwise
= return ()
where
+ ctxt = case mb_ctxt of
+ Nothing -> convertHsMatchCtxt $ m_ctxt (unLoc match1)
+ Just x -> x
n_args1 = args_in_match match1
mb_bad_matches = NE.nonEmpty [m | m <- matches, args_in_match m /= n_args1]
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 178c85a24a8fca029d2cc9c1053f4d676ac95a3c..658db74518bcd978cae3d45c48f28b5da8a17c69 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -20,6 +20,7 @@ module GHC.Tc.Gen.Pat
, tcCheckPat, tcCheckPat_O, tcInferPat
, tcPats
, addDataConStupidTheta
+ , isIrrefutableHsPatRnTcM
)
where
@@ -75,6 +76,7 @@ import GHC.Data.List.SetOps ( getNth )
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Data.List( partition )
+import Data.Maybe (isJust)
{-
************************************************************************
@@ -122,7 +124,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
-----------------
tcPats :: HsMatchContext GhcTc
- -> [LPat GhcRn] -- ^ atterns
+ -> [LPat GhcRn] -- ^ patterns
-> [ExpPatType] -- ^ types of the patterns
-> TcM a -- ^ checker for the body
-> TcM ([LPat GhcTc], a)
@@ -1735,3 +1737,27 @@ checkGADT conlike ex_tvs arg_tys = \case
where
has_existentials :: Bool
has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs
+
+-- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't typecheck the pattern
+-- It does depend on the type checker monad (`TcM`) however as we need to check ConPat case in more detail.
+-- Specifically, we call `tcLookupGlobal` to obtain constructor details from global packages
+-- for a comprehensive irrefutability check and avoid false negatives. (testcase pattern-fails.hs)
+isIrrefutableHsPatRnTcM :: Bool -> LPat GhcRn -> TcM Bool
+isIrrefutableHsPatRnTcM is_strict = isIrrefutableHsPatHelperM is_strict isConLikeIrr
+ where
+ doWork is_strict = isIrrefutableHsPatHelperM is_strict isConLikeIrr
+
+ isConLikeIrr is_strict (L _ dcName) details =
+ do { tyth <- tcLookupGlobal dcName
+ ; case tyth of
+ (ATyCon tycon) -> doCheck is_strict tycon details
+ (AConLike cl) ->
+ case cl of
+ RealDataCon dc -> doCheck is_strict (dataConTyCon dc) details
+ PatSynCon _pat -> return False -- conservative
+ _ -> return False -- conservative
+ }
+
+ doCheck is_strict tycon details = do { let b = isJust (tyConSingleDataCon_maybe tycon)
+ ; bs <- mapM (doWork is_strict) (hsConPatArgs details)
+ ; return (b && and bs) }
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 50f20ff545e7649f8d47c4b93f04247fb6539ea8..45640c16c5aeff5be4a6afddf732ad674e2a4db7 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1976,8 +1976,7 @@ lookupName is_type_name s
getThSpliceOrigin :: TcM Origin
getThSpliceOrigin = do
warn <- goptM Opt_EnableThSpliceWarnings
- if warn then return FromSource else return (Generated SkipPmc)
-
+ if warn then return FromSource else return (Generated OtherExpansion SkipPmc)
getThing :: TH.Name -> TcM TcTyThing
getThing th_name
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index f721dc789f3fb0c9696acb3790aa886fc351c8b9..f41cd8e9d07b2d21ba75db6a26f06ab95445a9ac 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -2219,7 +2219,7 @@ mkDefMethBind loc dfun_id clas sel_id dm_name
, tyConBinderForAllTyFlag tcb /= Inferred ]
rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
bind = L (noAnnSrcSpan loc)
- $ mkTopFunBind (Generated SkipPmc) fn
+ $ mkTopFunBind (Generated OtherExpansion SkipPmc) fn
[mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body"
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 5ddbc729c596dcbc3f91246808376357e02282e1..f3b0a7c2a33dd3fcac52ed07906d672c7737a4b9 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -60,7 +60,7 @@ import GHC.Tc.TyCl.Utils
import GHC.Core.ConLike
import GHC.Types.FieldLabel
import GHC.Rename.Env
-import GHC.Rename.Utils (wrapGenSpan, isIrrefutableHsPatRn)
+import GHC.Rename.Utils (wrapGenSpan, isIrrefutableHsPat)
import GHC.Data.Bag
import GHC.Utils.Misc
import GHC.Driver.DynFlags ( getDynFlags, xopt_FieldSelectors )
@@ -788,11 +788,11 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
args = map nlVarPat [scrutinee, cont, fail]
lwpat = noLocA $ WildPat pat_ty
- cases = if isIrrefutableHsPatRn dflags lpat
+ cases = if isIrrefutableHsPat dflags lpat
then [mkHsCaseAlt lpat cont']
else [mkHsCaseAlt lpat cont',
mkHsCaseAlt lwpat fail']
- gen = Generated SkipPmc
+ gen = Generated OtherExpansion SkipPmc
body = mkLHsWrap (mkWpLet req_ev_binds) $
L (getLoc lpat) $
HsCase PatSyn (nlHsVar scrutinee) $
@@ -941,7 +941,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
Unidirectional -> panic "tcPatSynBuilderBind"
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
- mk_mg body = mkMatchGroup (Generated SkipPmc) (noLocA [builder_match])
+ mk_mg body = mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [builder_match])
where
builder_args = [L (l2l loc) (VarPat noExtField (L loc n))
| L loc n <- args]
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 2592d1efbf2f5f06217a803410f67b03a7ac12e7..aac22b5cff352c922a02f2ce290b5ea423460480 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -933,7 +933,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- make the binding: sel (C2 { fld = x }) = x
-- sel (C7 { fld = x }) = x
-- where cons_w_field = [C2,C7]
- sel_bind = mkTopFunBind (Generated SkipPmc) sel_lname alts
+ sel_bind = mkTopFunBind (Generated OtherExpansion SkipPmc) sel_lname alts
where
alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)
[] unit_rhs]
diff --git a/compiler/GHC/Tc/Types/ErrCtxt.hs b/compiler/GHC/Tc/Types/ErrCtxt.hs
index 35d10421ff768a6a71e8214b5fb030d8d62dc38c..c9cdf15eb107356db831a725087d82f786d4700b 100644
--- a/compiler/GHC/Tc/Types/ErrCtxt.hs
+++ b/compiler/GHC/Tc/Types/ErrCtxt.hs
@@ -13,4 +13,4 @@ type ErrCtxt = (Bool, TidyEnv -> ZonkM (TidyEnv, SDoc))
-- message construction
-- Bool: True <=> this is a landmark context; do not
- -- discard it when trimming for display
\ No newline at end of file
+ -- discard it when trimming for display
diff --git a/compiler/GHC/Tc/Types/LclEnv.hs b/compiler/GHC/Tc/Types/LclEnv.hs
index 38561bc67e72ac65c33995401521c78059f9c02b..0a732f04580d4d266a3ad8bc256b8f66d37ad43e 100644
--- a/compiler/GHC/Tc/Types/LclEnv.hs
+++ b/compiler/GHC/Tc/Types/LclEnv.hs
@@ -90,7 +90,7 @@ data TcLclCtxt
= TcLclCtxt {
tcl_loc :: RealSrcSpan, -- Source span
tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top
- tcl_in_gen_code :: Bool, -- See Note [Rebindable syntax and HsExpansion]
+ tcl_in_gen_code :: Bool, -- See Note [Rebindable syntax and XXExprGhcRn]
tcl_tclvl :: TcLevel,
tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings,
-- and for tidying type
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 2d69db826b14757b2d84ea57d5b2aee23d6f5885..246cfe5fba125e65fcdff9e5d4dead70cd28eab4 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -740,7 +740,10 @@ exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice"
exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression"
-exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a
+exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOrigin a
+ | OrigStmt _ <- thing = DoOrigin
+ | OrigPat p <- thing = DoPatOrigin p
+exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
@@ -1385,9 +1388,9 @@ data ExpectedFunTyOrigin
--
-- Test cases for representation-polymorphism checks:
-- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK
- = ExpectedFunTySyntaxOp
- !CtOrigin
- !(HsExpr GhcRn)
+ = forall (p :: Pass)
+ . (OutputableBndrId p)
+ => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p))
-- ^ rebindable syntax operator
-- | A view pattern must have a function type.
@@ -1403,8 +1406,7 @@ data ExpectedFunTyOrigin
-- Test cases for representation-polymorphism checks:
-- RepPolyApp
| forall (p :: Pass)
- . (OutputableBndrId p)
- => ExpectedFunTyArg
+ . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg
!TypedThing
-- ^ function
!(HsExpr (GhcPass p))
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index 5772d28d01ffbaec00f25e620ea89958e3610c8d..6ce7aea8788cf16ce62593f143f62c30577f2da9 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -706,7 +706,7 @@ newNonTrivialOverloadedLit
orig = LiteralOrigin lit
------------
-mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
+mkOverLit :: OverLitVal -> TcM (HsLit (GhcPass p))
mkOverLit (HsIntegral i)
= do { integer_ty <- tcMetaTy integerTyConName
; return (HsInteger (il_text i)
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 86fb121147e515ea9bb22cde69f896dfd819603d..57be821960e7c5253104d53ba22c6dfad62303a9 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -1212,7 +1212,7 @@ Note [Error contexts in generated code]
So typically it's better to do setSrcSpan /before/ addErrCtxt.
-See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for
+See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr for
more discussion of this fancy footwork, as well as
Note [Generated code and pattern-match checking] in GHC.Types.Basic for the
relation with pattern-match checks.
@@ -1256,13 +1256,14 @@ pushCtxt ctxt = updLclEnv (updCtxt ctxt)
updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
-- Do not update the context if we are in generated code
--- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
+-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
updCtxt ctxt env
| lclEnvInGeneratedCode env = env
| otherwise = addLclEnvErrCtxt ctxt env
popErrCtxt :: TcM a -> TcM a
-popErrCtxt = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env)
+popErrCtxt thing_inside = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $
+ thing_inside
where
pop [] = []
pop (_:msgs) = msgs
@@ -1293,7 +1294,6 @@ setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
$ setLclEnvBinderStack (ctl_bndrs lcl)
$ env) thing_inside
-
{- *********************************************************************
* *
Error recovery and exceptions
diff --git a/compiler/GHC/Tc/Zonk/Type.hs b/compiler/GHC/Tc/Zonk/Type.hs
index cfc5c2d807870ad18f94214f5710e1582ac36edc..0ac35fce036fd73a9ecdce183f10f887a97baae1 100644
--- a/compiler/GHC/Tc/Zonk/Type.hs
+++ b/compiler/GHC/Tc/Zonk/Type.hs
@@ -1080,8 +1080,10 @@ zonkExpr (XExpr (WrapExpr (HsWrap co_fn expr)))
do new_expr <- zonkExpr expr
return (XExpr (WrapExpr (HsWrap new_co_fn new_expr)))
-zonkExpr (XExpr (ExpansionExpr (HsExpanded a b)))
- = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr b
+zonkExpr (XExpr (ExpandedThingTc thing e))
+ = do e' <- zonkExpr e
+ return $ XExpr (ExpandedThingTc thing e')
+
zonkExpr (XExpr (ConLikeTc con tvs tys))
= XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index cb806eb425a6821f2cb8ce6fe08373683be12979..45c353895a6e06e62b0474c3328cb32c5e27e3d4 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -38,6 +38,8 @@ module GHC.Types.Basic (
RecFlag(..), isRec, isNonRec, boolToRecFlag,
Origin(..), isGenerated, DoPmc(..), requiresPMC,
+ GenReason(..), isDoExpansionGenerated, doExpansionFlavour,
+ doExpansionOrigin,
RuleName, pprRuleName,
@@ -131,6 +133,7 @@ import GHC.Types.SourceText
import qualified GHC.LanguageExtensions as LangExt
import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted)
import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag)
+import {-# SOURCE #-} Language.Haskell.Syntax.Expr (HsDoFlavour)
import Control.DeepSeq ( NFData(..) )
import Data.Data
@@ -588,16 +591,43 @@ instance Binary RecFlag where
--
-- See Note [Generated code and pattern-match checking].
data Origin = FromSource
- | Generated DoPmc
+ | Generated GenReason DoPmc
deriving( Eq, Data )
isGenerated :: Origin -> Bool
-isGenerated Generated {} = True
+isGenerated Generated{} = True
isGenerated FromSource = False
+-- | This metadata stores the information as to why was the piece of code generated
+-- It is useful for generating the right error context
+-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
+data GenReason = DoExpansion HsDoFlavour
+ | OtherExpansion
+ deriving (Eq, Data)
+
+instance Outputable GenReason where
+ ppr DoExpansion{} = text "DoExpansion"
+ ppr OtherExpansion = text "OtherExpansion"
+
+doExpansionFlavour :: Origin -> Maybe HsDoFlavour
+doExpansionFlavour (Generated (DoExpansion f) _) = Just f
+doExpansionFlavour _ = Nothing
+
+-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
+isDoExpansionGenerated :: Origin -> Bool
+isDoExpansionGenerated = isJust . doExpansionFlavour
+
+-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
+doExpansionOrigin :: HsDoFlavour -> Origin
+doExpansionOrigin f = Generated (DoExpansion f) DoPmc
+ -- It is important that we perfrom PMC
+ -- on the expressions generated by do statements
+ -- to get the right pattern match checker warnings
+ -- See `GHC.HsToCore.Pmc.pmcMatches`
+
instance Outputable Origin where
- ppr FromSource = text "FromSource"
- ppr (Generated pmc) = text "Generated" <+> ppr pmc
+ ppr FromSource = text "FromSource"
+ ppr (Generated reason pmc) = text "Generated" <+> ppr reason <+> ppr pmc
-- | Whether to run pattern-match checks in generated code.
--
@@ -615,14 +645,14 @@ instance Outputable DoPmc where
--
-- See Note [Generated code and pattern-match checking].
requiresPMC :: Origin -> Bool
-requiresPMC (Generated SkipPmc) = False
+requiresPMC (Generated _ SkipPmc) = False
requiresPMC _ = True
{- Note [Generated code and pattern-match checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Some parts of the compiler generate code that is then typechecked. For example:
- - the HsExpansion mechanism described in Note [Rebindable syntax and HsExpansion]
+ - the XXExprGhcRn mechanism described in Note [Rebindable syntax and XXExprGhcRn]
in GHC.Hs.Expr,
- the deriving mechanism.
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index a2447ec52e5ddab3a62c7600aeb5cc321d5e2f00..5c732a18015570df17f02357a04e64612e1901bc 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -239,7 +239,7 @@ this if both data types are declared in the same module.
NB 2: The notation getField @"size" e is short for
HsApp (HsAppType (HsVar "getField") (HsWC (HsTyLit (HsStrTy "size")) [])) e.
-We track the original parsed syntax via HsExpanded.
+We track the original parsed syntax via ExpandedThingRn.
-}
@@ -581,7 +581,7 @@ data HsExpr p
| XExpr !(XXExpr p)
-- Note [Trees That Grow] in Language.Haskell.Syntax.Extension for the
- -- general idea, and Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
+ -- general idea, and Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
-- for an example of how we use it.
-- ---------------------------------------------------------------------
@@ -1608,6 +1608,7 @@ data HsDoFlavour
| GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs
| ListComp
| MonadComp
+ deriving (Eq, Data)
qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName
qualifiedDoModuleName_maybe ctxt = case ctxt of
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs-boot b/compiler/Language/Haskell/Syntax/Expr.hs-boot
index b6a0d7943105e4d7286f528e50f3db0339a47a7f..1b489a1f4d8191457b4d23c0500fd9abdfcc81ef 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs-boot
+++ b/compiler/Language/Haskell/Syntax/Expr.hs-boot
@@ -9,6 +9,9 @@ module Language.Haskell.Syntax.Expr where
import Language.Haskell.Syntax.Extension ( XRec )
import Data.Kind ( Type )
+import GHC.Prelude (Eq)
+import Data.Data (Data)
+
type role HsExpr nominal
type role MatchGroup nominal nominal
type role GRHSs nominal nominal
@@ -20,3 +23,7 @@ data GRHSs (a :: Type) (body :: Type)
type family SyntaxExpr (i :: Type)
type LHsExpr a = XRec a (HsExpr a)
+
+data HsDoFlavour
+instance Eq HsDoFlavour
+instance Data HsDoFlavour
\ No newline at end of file
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 5039fbe5b7601e3abe644bf7af4c7e21c731586f..82fd079b47d5547b0298e6180c6090f1d901dd5b 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -760,6 +760,7 @@ Library
GHC.Tc.Gen.Arrow
GHC.Tc.Gen.Bind
GHC.Tc.Gen.Default
+ GHC.Tc.Gen.Do
GHC.Tc.Gen.Export
GHC.Tc.Gen.Expr
GHC.Tc.Gen.Foreign
diff --git a/testsuite/tests/deSugar/should_compile/T3263-2.hs b/testsuite/tests/deSugar/should_compile/T3263-2.hs
index f018ddb4d9affdc9cbf63d673addb21d0d1e5d65..c280df7bc67d7237e2d4a8b60dc5d31ec97bd39d 100644
--- a/testsuite/tests/deSugar/should_compile/T3263-2.hs
+++ b/testsuite/tests/deSugar/should_compile/T3263-2.hs
@@ -35,4 +35,17 @@ t5 = do
t6 :: forall m. MonadFix m => m Int
t6 = mdo
return (return 10 :: m Int)
- return 10
\ No newline at end of file
+ return 10
+
+unit :: ()
+unit = ()
+
+-- No warning
+t7 :: forall m. Monad m => m Int
+t7 = do
+ return unit
+ return 10
+
+-- No warning
+t8 :: Monad m => m Int
+t8 = return 10 >> return 10
diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
index 918b39eb90b636f9d198d1546b823724cfc569b3..5e5ce6e13aa0b82d830697c2117dd3073fc2cb50 100644
--- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
+++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
@@ -44,7 +44,7 @@ main = do
forall (a :: k) (b :: j) ->
() |]
let hs_t = fromRight (error "convertToHsType") $
- convertToHsType (Generated SkipPmc) noSrcSpan th_t
+ convertToHsType (Generated OtherExpansion SkipPmc) noSrcSpan th_t
(messages, mres) <-
tcRnType hsc_env SkolemiseFlexi True hs_t
let (warnings, errors) = partitionMessages messages
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr
index 49fc6560d3578df7c81ee29f419a96e48bf06309..974c43cd22edfea02c42f5f1b8c38839c2f08ee6 100644
--- a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr
@@ -4,7 +4,4 @@ RecordDotSyntaxFail9.hs:7:11: error: [GHC-18872]
arising from selecting the field ‘foo’
• In the expression: a.foo :: String
In a pattern binding: _ = a.foo :: String
- In the expression:
- do let a = ...
- let _ = ...
- undefined
+ In a stmt of a 'do' block: let _ = a.foo :: String
diff --git a/testsuite/tests/pmcheck/should_compile/DoubleMatch.hs b/testsuite/tests/pmcheck/should_compile/DoubleMatch.hs
new file mode 100644
index 0000000000000000000000000000000000000000..5dab72dd14706dc738234d1d62de4d8fcd530652
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/DoubleMatch.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE CApiFFI, CPP, DeriveDataTypeable, NondecreasingIndentation #-}
+{-# OPTIONS_GHC -Wincomplete-patterns #-}
+{-# OPTIONS_GHC -fno-cse #-}
+module DoubleMatch where
+
+data Handler = Default
+ | Handler1
+
+doingThing :: Handler -> IO Int
+doingThing handler = do
+ v <- case handler of
+ Default -> return 0
+ _other_Handler -> do
+ asdf <- return 1
+ let action = case handler of
+ Handler1 -> 1
+ return action
+ return v
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index a7c8a194ea81cee4e3c0e8f5be7cc2742b080aa4..b2b0114d419bd914ce35b82cb69953daaba0e2da 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -168,3 +168,4 @@ test('EmptyCase010', [], compile, [overlapping_incomplete])
test('DsIncompleteRecSel1', normal, compile, ['-Wincomplete-record-selectors'])
test('DsIncompleteRecSel2', normal, compile, ['-Wincomplete-record-selectors'])
test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors'])
+test('DoubleMatch', normal, compile, [overlapping_incomplete])
diff --git a/testsuite/tests/profiling/should_run/caller-cc/CallerCc1.prof.sample b/testsuite/tests/profiling/should_run/caller-cc/CallerCc1.prof.sample
index bd653712eac3cf698facb78873fc0779619139d7..aae908b4d38eae7af4725af40bf8463eb5ca6fdb 100644
--- a/testsuite/tests/profiling/should_run/caller-cc/CallerCc1.prof.sample
+++ b/testsuite/tests/profiling/should_run/caller-cc/CallerCc1.prof.sample
@@ -1,79 +1,79 @@
- Fri Nov 13 01:06 2020 Time and Allocation Profiling Report (Final)
+ Thu Oct 12 08:47 2023 Time and Allocation Profiling Report (Final)
CallerCc1 +RTS -hc -p -RTS 7
- total time = 0.09 secs (87 ticks @ 1000 us, 1 processor)
- total alloc = 105,486,200 bytes (excludes profiling overheads)
+ total time = 0.14 secs (138 ticks @ 1000 us, 1 processor)
+ total alloc = 104,890,152 bytes (excludes profiling overheads)
COST CENTRE MODULE SRC %time %alloc
-disin Main Main.hs:(74,1)-(83,11) 35.6 49.5
-insert Main Main.hs:(108,1)-(112,8) 21.8 1.7
-clause.clause' Main Main.hs:(63,12)-(65,57) 17.2 37.5
-unicl.unicl' Main Main.hs:(178,11)-(180,36) 6.9 2.6
-conjunct Main Main.hs:(70,1)-(71,18) 5.7 0.0
-split.split' Main Main.hs:(165,11)-(166,28) 3.4 2.3
-disin.dp Main Main.hs:80:3-14 3.4 0.0
-unicl Main Main.hs:(176,1)-(180,36) 2.3 1.1
-tautclause Main Main.hs:173:1-49 2.3 3.7
-disin.dq Main Main.hs:81:3-14 1.1 0.0
+disin Main Main.hs:(74,1)-(83,11) 36.2 49.8
+insert Main Main.hs:(108,1)-(112,8) 26.8 1.7
+clause.clause' Main Main.hs:(63,12)-(65,57) 18.8 37.7
+conjunct Main Main.hs:(70,1)-(71,18) 6.5 0.0
+tautclause Main Main.hs:173:1-49 3.6 3.7
+split.split' Main Main.hs:(165,11)-(166,28) 3.6 2.3
+unicl.unicl' Main Main.hs:(178,11)-(180,36) 2.2 2.0
+disin.dp Main Main.hs:80:3-14 1.4 0.0
+unicl Main Main.hs:(176,1)-(180,36) 0.0 1.1
clause Main Main.hs:(61,1)-(65,57) 0.0 1.4
individual inherited
COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc
-MAIN MAIN <built-in> 128 0 0.0 0.0 100.0 100.0
- CAF Main <entire-module> 255 0 0.0 0.0 0.0 0.0
- clauses Main Main.hs:68:1-74 261 1 0.0 0.0 0.0 0.0
- Main.clauses(calling:Data.Foldable.concat) Main Main.hs:68:1-7 263 1 0.0 0.0 0.0 0.0
- main Main Main.hs:(42,1)-(44,23) 256 1 0.0 0.0 0.0 0.0
- redstar Main Main.hs:155:1-35 279 1 0.0 0.0 0.0 0.0
- spaces Main Main.hs:160:1-19 303 1 0.0 0.0 0.0 0.0
- CAF GHC.Conc.Signal <entire-module> 246 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Encoding <entire-module> 235 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Encoding.Iconv <entire-module> 233 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Handle.FD <entire-module> 225 0 0.0 0.0 0.0 0.0
- main Main Main.hs:(42,1)-(44,23) 257 0 0.0 0.0 100.0 100.0
- res Main Main.hs:(46,1)-(48,26) 258 1 0.0 0.0 100.0 99.9
- Main.main(calling:Data.Foldable.concat) Main Main.hs:42:1-4 259 1 0.0 0.0 0.0 0.0
- res.xs Main Main.hs:47:8-69 260 1 0.0 0.0 0.0 0.0
- clauses Main Main.hs:68:1-74 262 0 0.0 0.0 100.0 99.9
- disin Main Main.hs:(74,1)-(83,11) 267 857598 35.6 49.5 46.0 49.5
- conjunct Main Main.hs:(70,1)-(71,18) 291 759353 5.7 0.0 5.7 0.0
- disin.dp Main Main.hs:80:3-14 292 380009 3.4 0.0 3.4 0.0
- disin.dq Main Main.hs:81:3-14 293 380009 1.1 0.0 1.1 0.0
- negin Main Main.hs:(119,1)-(124,11) 268 1617 0.0 0.1 0.0 0.1
- elim Main Main.hs:(89,1)-(94,57) 269 1393 0.0 0.1 0.0 0.1
- disp Main Main.hs:86:1-71 301 7 0.0 0.0 0.0 0.0
- interleave Main Main.hs:(115,1)-(116,25) 302 35 0.0 0.0 0.0 0.0
- parse Main Main.hs:135:1-39 270 7 0.0 0.0 0.0 0.0
- parse.(...) Main Main.hs:135:19-39 272 7 0.0 0.0 0.0 0.0
- parse' Main Main.hs:(137,1)-(145,42) 273 280 0.0 0.0 0.0 0.0
- opri Main Main.hs:(127,1)-(132,12) 276 56 0.0 0.0 0.0 0.0
- spri Main Main.hs:(169,1)-(170,10) 274 56 0.0 0.0 0.0 0.0
- opri Main Main.hs:(127,1)-(132,12) 275 49 0.0 0.0 0.0 0.0
- parse'.(...) Main Main.hs:142:20-49 278 21 0.0 0.0 0.0 0.0
- redstar Main Main.hs:155:1-35 280 0 0.0 0.0 0.0 0.0
- spri Main Main.hs:(169,1)-(170,10) 282 63 0.0 0.0 0.0 0.0
- opri Main Main.hs:(127,1)-(132,12) 283 63 0.0 0.0 0.0 0.0
- while Main Main.hs:182:1-48 281 63 0.0 0.0 0.0 0.0
- red Main Main.hs:(148,1)-(152,43) 284 42 0.0 0.0 0.0 0.0
- parse'.s' Main Main.hs:142:20-49 285 21 0.0 0.0 0.0 0.0
- parse'.x Main Main.hs:142:20-49 277 21 0.0 0.0 0.0 0.0
- redstar Main Main.hs:155:1-35 286 0 0.0 0.0 0.0 0.0
- spri Main Main.hs:(169,1)-(170,10) 288 21 0.0 0.0 0.0 0.0
- opri Main Main.hs:(127,1)-(132,12) 289 14 0.0 0.0 0.0 0.0
- while Main Main.hs:182:1-48 287 21 0.0 0.0 0.0 0.0
- red Main Main.hs:(148,1)-(152,43) 290 14 0.0 0.0 0.0 0.0
- parse.f Main Main.hs:135:19-39 271 7 0.0 0.0 0.0 0.0
- split Main Main.hs:(163,1)-(166,28) 265 7 0.0 0.0 3.4 2.3
- split.split' Main Main.hs:(165,11)-(166,28) 266 74837 3.4 2.3 3.4 2.3
- unicl Main Main.hs:(176,1)-(180,36) 264 7 2.3 1.1 50.6 48.0
- unicl.unicl' Main Main.hs:(178,11)-(180,36) 294 37422 6.9 2.6 48.3 46.9
- tautclause Main Main.hs:173:1-49 295 37422 2.3 3.7 2.3 3.7
- unicl.unicl'.cp Main Main.hs:180:24-36 296 37422 0.0 0.0 39.1 40.6
- clause Main Main.hs:(61,1)-(65,57) 297 37422 0.0 1.4 39.1 40.6
- clause.clause' Main Main.hs:(63,12)-(65,57) 298 696150 17.2 37.5 39.1 39.2
- insert Main Main.hs:(108,1)-(112,8) 299 366786 21.8 1.7 21.8 1.7
- insert Main Main.hs:(108,1)-(112,8) 300 7 0.0 0.0 0.0 0.0
+MAIN MAIN <built-in> 137 0 0.0 0.0 100.0 100.0
+ CAF Main <entire-module> 273 0 0.0 0.0 0.0 0.0
+ clauses Main Main.hs:68:1-74 280 1 0.0 0.0 0.0 0.0
+ Main.clauses(calling:Data.Foldable.concat) Main Main.hs:68:1-7 282 1 0.0 0.0 0.0 0.0
+ main Main Main.hs:(42,1)-(44,23) 274 1 0.0 0.0 0.0 0.0
+ redstar Main Main.hs:155:1-35 298 1 0.0 0.0 0.0 0.0
+ spaces Main Main.hs:160:1-19 322 1 0.0 0.0 0.0 0.0
+ CAF GHC.Conc.Signal <entire-module> 251 0 0.0 0.0 0.0 0.0
+ CAF GHC.IO.Encoding <entire-module> 232 0 0.0 0.0 0.0 0.0
+ CAF GHC.IO.Encoding.Iconv <entire-module> 230 0 0.0 0.0 0.0 0.0
+ CAF GHC.IO.Handle.FD <entire-module> 221 0 0.0 0.0 0.0 0.0
+ main Main Main.hs:(42,1)-(44,23) 275 0 0.0 0.0 100.0 100.0
+ main.\ Main Main.hs:44:3-23 276 1 0.0 0.0 100.0 100.0
+ res Main Main.hs:(46,1)-(48,26) 277 1 0.0 0.0 100.0 99.9
+ Main.main(calling:Data.Foldable.concat) Main Main.hs:42:1-4 278 1 0.0 0.0 0.0 0.0
+ res.xs Main Main.hs:47:8-69 279 1 0.0 0.0 0.0 0.0
+ clauses Main Main.hs:68:1-74 281 0 0.0 0.0 100.0 99.9
+ disin Main Main.hs:(74,1)-(83,11) 286 857598 36.2 49.8 44.2 49.8
+ conjunct Main Main.hs:(70,1)-(71,18) 310 759353 6.5 0.0 6.5 0.0
+ disin.dp Main Main.hs:80:3-14 311 380009 1.4 0.0 1.4 0.0
+ disin.dq Main Main.hs:81:3-14 312 380009 0.0 0.0 0.0 0.0
+ negin Main Main.hs:(119,1)-(124,11) 287 1617 0.7 0.1 0.7 0.1
+ elim Main Main.hs:(89,1)-(94,57) 288 1393 0.0 0.1 0.0 0.1
+ disp Main Main.hs:86:1-71 320 7 0.0 0.0 0.0 0.0
+ interleave Main Main.hs:(115,1)-(116,25) 321 35 0.0 0.0 0.0 0.0
+ parse Main Main.hs:135:1-39 289 7 0.0 0.0 0.0 0.0
+ parse.(...) Main Main.hs:135:19-39 291 7 0.0 0.0 0.0 0.0
+ parse' Main Main.hs:(137,1)-(145,42) 292 280 0.0 0.0 0.0 0.0
+ opri Main Main.hs:(127,1)-(132,12) 295 56 0.0 0.0 0.0 0.0
+ spri Main Main.hs:(169,1)-(170,10) 293 56 0.0 0.0 0.0 0.0
+ opri Main Main.hs:(127,1)-(132,12) 294 49 0.0 0.0 0.0 0.0
+ parse'.(...) Main Main.hs:142:20-49 297 21 0.0 0.0 0.0 0.0
+ redstar Main Main.hs:155:1-35 299 0 0.0 0.0 0.0 0.0
+ spri Main Main.hs:(169,1)-(170,10) 301 63 0.0 0.0 0.0 0.0
+ opri Main Main.hs:(127,1)-(132,12) 302 63 0.0 0.0 0.0 0.0
+ while Main Main.hs:182:1-48 300 63 0.0 0.0 0.0 0.0
+ red Main Main.hs:(148,1)-(152,43) 303 42 0.0 0.0 0.0 0.0
+ parse'.s' Main Main.hs:142:20-49 304 21 0.0 0.0 0.0 0.0
+ parse'.x Main Main.hs:142:20-49 296 21 0.0 0.0 0.0 0.0
+ redstar Main Main.hs:155:1-35 305 0 0.0 0.0 0.0 0.0
+ spri Main Main.hs:(169,1)-(170,10) 307 21 0.0 0.0 0.0 0.0
+ opri Main Main.hs:(127,1)-(132,12) 308 14 0.0 0.0 0.0 0.0
+ while Main Main.hs:182:1-48 306 21 0.0 0.0 0.0 0.0
+ red Main Main.hs:(148,1)-(152,43) 309 14 0.0 0.0 0.0 0.0
+ parse.f Main Main.hs:135:19-39 290 7 0.0 0.0 0.0 0.0
+ split Main Main.hs:(163,1)-(166,28) 284 7 0.0 0.0 3.6 2.3
+ split.split' Main Main.hs:(165,11)-(166,28) 285 74837 3.6 2.3 3.6 2.3
+ unicl Main Main.hs:(176,1)-(180,36) 283 7 0.0 1.1 51.4 47.7
+ unicl.unicl' Main Main.hs:(178,11)-(180,36) 313 37422 2.2 2.0 51.4 46.6
+ tautclause Main Main.hs:173:1-49 314 37422 3.6 3.7 3.6 3.7
+ unicl.unicl'.cp Main Main.hs:180:24-36 315 37422 0.0 0.0 45.7 40.9
+ clause Main Main.hs:(61,1)-(65,57) 316 37422 0.0 1.4 45.7 40.9
+ clause.clause' Main Main.hs:(63,12)-(65,57) 317 696150 18.8 37.7 45.7 39.5
+ insert Main Main.hs:(108,1)-(112,8) 318 366786 26.8 1.7 26.8 1.7
+ insert Main Main.hs:(108,1)-(112,8) 319 7 0.0 0.0 0.0 0.0
diff --git a/testsuite/tests/profiling/should_run/caller-cc/CallerCc2.prof.sample b/testsuite/tests/profiling/should_run/caller-cc/CallerCc2.prof.sample
index d35a0d8350b6858c54f115adb8a29fda947cb2d3..b9ee0bd2761eda6490cc6a09662df2d7ff0553b4 100644
--- a/testsuite/tests/profiling/should_run/caller-cc/CallerCc2.prof.sample
+++ b/testsuite/tests/profiling/should_run/caller-cc/CallerCc2.prof.sample
@@ -1,78 +1,81 @@
- Fri Nov 13 01:06 2020 Time and Allocation Profiling Report (Final)
+ Thu Oct 12 08:47 2023 Time and Allocation Profiling Report (Final)
CallerCc2 +RTS -hc -p -RTS 7
- total time = 0.09 secs (91 ticks @ 1000 us, 1 processor)
- total alloc = 105,486,200 bytes (excludes profiling overheads)
+ total time = 0.13 secs (127 ticks @ 1000 us, 1 processor)
+ total alloc = 104,890,152 bytes (excludes profiling overheads)
COST CENTRE MODULE SRC %time %alloc
-disin Main Main.hs:(74,1)-(83,11) 26.4 49.5
-clause.clause' Main Main.hs:(63,12)-(65,57) 23.1 37.5
-insert Main Main.hs:(108,1)-(112,8) 18.7 1.7
-conjunct Main Main.hs:(70,1)-(71,18) 8.8 0.0
-unicl.unicl' Main Main.hs:(178,11)-(180,36) 5.5 2.6
-tautclause Main Main.hs:173:1-49 5.5 3.7
-unicl Main Main.hs:(176,1)-(180,36) 3.3 1.1
-split.split' Main Main.hs:(165,11)-(166,28) 3.3 2.3
-disin.dp Main Main.hs:80:3-14 3.3 0.0
-clause Main Main.hs:(61,1)-(65,57) 2.2 1.4
+disin Main Main.hs:(74,1)-(83,11) 32.3 49.8
+insert Main Main.hs:(108,1)-(112,8) 21.3 1.7
+clause.clause' Main Main.hs:(63,12)-(65,57) 20.5 37.7
+conjunct Main Main.hs:(70,1)-(71,18) 8.7 0.0
+tautclause Main Main.hs:173:1-49 6.3 3.7
+disin.dp Main Main.hs:80:3-14 3.9 0.0
+disin.dq Main Main.hs:81:3-14 2.4 0.0
+split.split' Main Main.hs:(165,11)-(166,28) 1.6 2.3
+parse' Main Main.hs:(137,1)-(145,42) 1.6 0.0
+unicl.unicl' Main Main.hs:(178,11)-(180,36) 0.8 2.0
+unicl Main Main.hs:(176,1)-(180,36) 0.8 1.1
+clause Main Main.hs:(61,1)-(65,57) 0.0 1.4
individual inherited
COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc
-MAIN MAIN <built-in> 128 0 0.0 0.0 100.0 100.0
- CAF Main <entire-module> 255 0 0.0 0.0 0.0 0.0
- clauses Main Main.hs:68:1-74 261 1 0.0 0.0 0.0 0.0
- Main.clauses(calling:Data.Foldable.concat) Main Main.hs:68:1-7 263 1 0.0 0.0 0.0 0.0
- main Main Main.hs:(42,1)-(44,23) 256 1 0.0 0.0 0.0 0.0
- redstar Main Main.hs:155:1-35 279 1 0.0 0.0 0.0 0.0
- spaces Main Main.hs:160:1-19 303 1 0.0 0.0 0.0 0.0
- CAF GHC.Conc.Signal <entire-module> 246 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Encoding <entire-module> 235 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Encoding.Iconv <entire-module> 233 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Handle.FD <entire-module> 225 0 0.0 0.0 0.0 0.0
- main Main Main.hs:(42,1)-(44,23) 257 0 0.0 0.0 100.0 100.0
- res Main Main.hs:(46,1)-(48,26) 258 1 0.0 0.0 100.0 99.9
- Main.main(calling:Data.Foldable.concat) Main Main.hs:42:1-4 259 1 0.0 0.0 0.0 0.0
- res.xs Main Main.hs:47:8-69 260 1 0.0 0.0 0.0 0.0
- clauses Main Main.hs:68:1-74 262 0 0.0 0.0 100.0 99.9
- disin Main Main.hs:(74,1)-(83,11) 267 857598 26.4 49.5 38.5 49.5
- conjunct Main Main.hs:(70,1)-(71,18) 291 759353 8.8 0.0 8.8 0.0
- disin.dp Main Main.hs:80:3-14 292 380009 3.3 0.0 3.3 0.0
- disin.dq Main Main.hs:81:3-14 293 380009 0.0 0.0 0.0 0.0
- negin Main Main.hs:(119,1)-(124,11) 268 1617 0.0 0.1 0.0 0.1
- elim Main Main.hs:(89,1)-(94,57) 269 1393 0.0 0.1 0.0 0.1
- disp Main Main.hs:86:1-71 301 7 0.0 0.0 0.0 0.0
- interleave Main Main.hs:(115,1)-(116,25) 302 35 0.0 0.0 0.0 0.0
- parse Main Main.hs:135:1-39 270 7 0.0 0.0 0.0 0.0
- parse.(...) Main Main.hs:135:19-39 272 7 0.0 0.0 0.0 0.0
- parse' Main Main.hs:(137,1)-(145,42) 273 280 0.0 0.0 0.0 0.0
- opri Main Main.hs:(127,1)-(132,12) 276 56 0.0 0.0 0.0 0.0
- spri Main Main.hs:(169,1)-(170,10) 274 56 0.0 0.0 0.0 0.0
- opri Main Main.hs:(127,1)-(132,12) 275 49 0.0 0.0 0.0 0.0
- parse'.(...) Main Main.hs:142:20-49 278 21 0.0 0.0 0.0 0.0
- redstar Main Main.hs:155:1-35 280 0 0.0 0.0 0.0 0.0
- spri Main Main.hs:(169,1)-(170,10) 282 63 0.0 0.0 0.0 0.0
- opri Main Main.hs:(127,1)-(132,12) 283 63 0.0 0.0 0.0 0.0
- while Main Main.hs:182:1-48 281 63 0.0 0.0 0.0 0.0
- red Main Main.hs:(148,1)-(152,43) 284 42 0.0 0.0 0.0 0.0
- parse'.s' Main Main.hs:142:20-49 285 21 0.0 0.0 0.0 0.0
- parse'.x Main Main.hs:142:20-49 277 21 0.0 0.0 0.0 0.0
- redstar Main Main.hs:155:1-35 286 0 0.0 0.0 0.0 0.0
- spri Main Main.hs:(169,1)-(170,10) 288 21 0.0 0.0 0.0 0.0
- opri Main Main.hs:(127,1)-(132,12) 289 14 0.0 0.0 0.0 0.0
- while Main Main.hs:182:1-48 287 21 0.0 0.0 0.0 0.0
- red Main Main.hs:(148,1)-(152,43) 290 14 0.0 0.0 0.0 0.0
- parse.f Main Main.hs:135:19-39 271 7 0.0 0.0 0.0 0.0
- split Main Main.hs:(163,1)-(166,28) 265 7 0.0 0.0 3.3 2.3
- split.split' Main Main.hs:(165,11)-(166,28) 266 74837 3.3 2.3 3.3 2.3
- unicl Main Main.hs:(176,1)-(180,36) 264 7 3.3 1.1 58.2 48.0
- unicl.unicl' Main Main.hs:(178,11)-(180,36) 294 37422 5.5 2.6 54.9 46.9
- tautclause Main Main.hs:173:1-49 295 37422 5.5 3.7 5.5 3.7
- unicl.unicl'.cp Main Main.hs:180:24-36 296 37422 0.0 0.0 44.0 40.6
- clause Main Main.hs:(61,1)-(65,57) 297 37422 2.2 1.4 44.0 40.6
- clause.clause' Main Main.hs:(63,12)-(65,57) 298 696150 23.1 37.5 41.8 39.2
- insert Main Main.hs:(108,1)-(112,8) 299 366786 18.7 1.7 18.7 1.7
- insert Main Main.hs:(108,1)-(112,8) 300 7 0.0 0.0 0.0 0.0
+MAIN MAIN <built-in> 137 0 0.0 0.0 100.0 100.0
+ CAF Main <entire-module> 273 0 0.0 0.0 0.0 0.0
+ clauses Main Main.hs:68:1-74 280 1 0.0 0.0 0.0 0.0
+ Main.clauses(calling:Data.Foldable.concat) Main Main.hs:68:1-7 282 1 0.0 0.0 0.0 0.0
+ main Main Main.hs:(42,1)-(44,23) 274 1 0.0 0.0 0.0 0.0
+ redstar Main Main.hs:155:1-35 298 1 0.0 0.0 0.0 0.0
+ spaces Main Main.hs:160:1-19 322 1 0.0 0.0 0.0 0.0
+ CAF GHC.Conc.Signal <entire-module> 251 0 0.0 0.0 0.0 0.0
+ CAF GHC.IO.Encoding <entire-module> 232 0 0.0 0.0 0.0 0.0
+ CAF GHC.IO.Encoding.Iconv <entire-module> 230 0 0.0 0.0 0.0 0.0
+ CAF GHC.IO.Handle.FD <entire-module> 221 0 0.0 0.0 0.0 0.0
+ main Main Main.hs:(42,1)-(44,23) 275 0 0.0 0.0 100.0 100.0
+ main.\ Main Main.hs:44:3-23 276 1 0.0 0.0 100.0 100.0
+ res Main Main.hs:(46,1)-(48,26) 277 1 0.0 0.0 100.0 99.9
+ Main.main(calling:Data.Foldable.concat) Main Main.hs:42:1-4 278 1 0.0 0.0 0.0 0.0
+ res.xs Main Main.hs:47:8-69 279 1 0.0 0.0 0.0 0.0
+ clauses Main Main.hs:68:1-74 281 0 0.0 0.0 100.0 99.9
+ disin Main Main.hs:(74,1)-(83,11) 286 857598 32.3 49.8 47.2 49.8
+ conjunct Main Main.hs:(70,1)-(71,18) 310 759353 8.7 0.0 8.7 0.0
+ disin.dp Main Main.hs:80:3-14 311 380009 3.9 0.0 3.9 0.0
+ disin.dq Main Main.hs:81:3-14 312 380009 2.4 0.0 2.4 0.0
+ negin Main Main.hs:(119,1)-(124,11) 287 1617 0.0 0.1 0.0 0.1
+ elim Main Main.hs:(89,1)-(94,57) 288 1393 0.0 0.1 0.0 0.1
+ disp Main Main.hs:86:1-71 320 7 0.0 0.0 0.0 0.0
+ interleave Main Main.hs:(115,1)-(116,25) 321 35 0.0 0.0 0.0 0.0
+ parse Main Main.hs:135:1-39 289 7 0.0 0.0 1.6 0.0
+ parse.(...) Main Main.hs:135:19-39 291 7 0.0 0.0 1.6 0.0
+ parse' Main Main.hs:(137,1)-(145,42) 292 280 1.6 0.0 1.6 0.0
+ opri Main Main.hs:(127,1)-(132,12) 295 56 0.0 0.0 0.0 0.0
+ spri Main Main.hs:(169,1)-(170,10) 293 56 0.0 0.0 0.0 0.0
+ opri Main Main.hs:(127,1)-(132,12) 294 49 0.0 0.0 0.0 0.0
+ parse'.(...) Main Main.hs:142:20-49 297 21 0.0 0.0 0.0 0.0
+ redstar Main Main.hs:155:1-35 299 0 0.0 0.0 0.0 0.0
+ spri Main Main.hs:(169,1)-(170,10) 301 63 0.0 0.0 0.0 0.0
+ opri Main Main.hs:(127,1)-(132,12) 302 63 0.0 0.0 0.0 0.0
+ while Main Main.hs:182:1-48 300 63 0.0 0.0 0.0 0.0
+ red Main Main.hs:(148,1)-(152,43) 303 42 0.0 0.0 0.0 0.0
+ parse'.s' Main Main.hs:142:20-49 304 21 0.0 0.0 0.0 0.0
+ parse'.x Main Main.hs:142:20-49 296 21 0.0 0.0 0.0 0.0
+ redstar Main Main.hs:155:1-35 305 0 0.0 0.0 0.0 0.0
+ spri Main Main.hs:(169,1)-(170,10) 307 21 0.0 0.0 0.0 0.0
+ opri Main Main.hs:(127,1)-(132,12) 308 14 0.0 0.0 0.0 0.0
+ while Main Main.hs:182:1-48 306 21 0.0 0.0 0.0 0.0
+ red Main Main.hs:(148,1)-(152,43) 309 14 0.0 0.0 0.0 0.0
+ parse.f Main Main.hs:135:19-39 290 7 0.0 0.0 0.0 0.0
+ split Main Main.hs:(163,1)-(166,28) 284 7 0.0 0.0 1.6 2.3
+ split.split' Main Main.hs:(165,11)-(166,28) 285 74837 1.6 2.3 1.6 2.3
+ unicl Main Main.hs:(176,1)-(180,36) 283 7 0.8 1.1 49.6 47.7
+ unicl.unicl' Main Main.hs:(178,11)-(180,36) 313 37422 0.8 2.0 48.8 46.6
+ tautclause Main Main.hs:173:1-49 314 37422 6.3 3.7 6.3 3.7
+ unicl.unicl'.cp Main Main.hs:180:24-36 315 37422 0.0 0.0 41.7 40.9
+ clause Main Main.hs:(61,1)-(65,57) 316 37422 0.0 1.4 41.7 40.9
+ clause.clause' Main Main.hs:(63,12)-(65,57) 317 696150 20.5 37.7 41.7 39.5
+ insert Main Main.hs:(108,1)-(112,8) 318 366786 21.3 1.7 21.3 1.7
+ insert Main Main.hs:(108,1)-(112,8) 319 7 0.0 0.0 0.0 0.0
diff --git a/testsuite/tests/profiling/should_run/caller-cc/CallerCc3.prof.sample b/testsuite/tests/profiling/should_run/caller-cc/CallerCc3.prof.sample
index 68fd783a35917d65ad154260cf274370cf291c4f..c44cfeaa124caf9ff7db9f340dc7535baea6696f 100644
--- a/testsuite/tests/profiling/should_run/caller-cc/CallerCc3.prof.sample
+++ b/testsuite/tests/profiling/should_run/caller-cc/CallerCc3.prof.sample
@@ -1,78 +1,78 @@
- Fri Nov 13 01:06 2020 Time and Allocation Profiling Report (Final)
+ Thu Oct 12 08:47 2023 Time and Allocation Profiling Report (Final)
CallerCc3 +RTS -hc -p -RTS 7
- total time = 0.09 secs (85 ticks @ 1000 us, 1 processor)
- total alloc = 105,486,200 bytes (excludes profiling overheads)
+ total time = 0.21 secs (208 ticks @ 1000 us, 1 processor)
+ total alloc = 104,890,152 bytes (excludes profiling overheads)
COST CENTRE MODULE SRC %time %alloc
-disin Main Main.hs:(74,1)-(83,11) 29.4 49.5
-insert Main Main.hs:(108,1)-(112,8) 24.7 1.7
-clause.clause' Main Main.hs:(63,12)-(65,57) 23.5 37.5
-conjunct Main Main.hs:(70,1)-(71,18) 10.6 0.0
-tautclause Main Main.hs:173:1-49 4.7 3.7
-unicl.unicl' Main Main.hs:(178,11)-(180,36) 3.5 2.6
-split.split' Main Main.hs:(165,11)-(166,28) 2.4 2.3
-disin.dp Main Main.hs:80:3-14 1.2 0.0
-unicl Main Main.hs:(176,1)-(180,36) 0.0 1.1
+disin Main Main.hs:(74,1)-(83,11) 29.8 49.8
+insert Main Main.hs:(108,1)-(112,8) 28.8 1.7
+clause.clause' Main Main.hs:(63,12)-(65,57) 22.6 37.7
+conjunct Main Main.hs:(70,1)-(71,18) 8.2 0.0
+tautclause Main Main.hs:173:1-49 5.8 3.7
+unicl.unicl' Main Main.hs:(178,11)-(180,36) 1.4 2.0
+split.split' Main Main.hs:(165,11)-(166,28) 1.4 2.3
+unicl Main Main.hs:(176,1)-(180,36) 0.5 1.1
clause Main Main.hs:(61,1)-(65,57) 0.0 1.4
individual inherited
COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc
-MAIN MAIN <built-in> 128 0 0.0 0.0 100.0 100.0
- CAF Main <entire-module> 255 0 0.0 0.0 0.0 0.0
- clauses Main Main.hs:68:1-74 261 1 0.0 0.0 0.0 0.0
- Main.clauses(calling:Data.Foldable.concat) Main Main.hs:68:1-7 263 1 0.0 0.0 0.0 0.0
- main Main Main.hs:(42,1)-(44,23) 256 1 0.0 0.0 0.0 0.0
- redstar Main Main.hs:155:1-35 279 1 0.0 0.0 0.0 0.0
- spaces Main Main.hs:160:1-19 303 1 0.0 0.0 0.0 0.0
- CAF GHC.Conc.Signal <entire-module> 246 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Encoding <entire-module> 235 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Encoding.Iconv <entire-module> 233 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Handle.FD <entire-module> 225 0 0.0 0.0 0.0 0.0
- main Main Main.hs:(42,1)-(44,23) 257 0 0.0 0.0 100.0 100.0
- res Main Main.hs:(46,1)-(48,26) 258 1 0.0 0.0 100.0 99.9
- Main.main(calling:Data.Foldable.concat) Main Main.hs:42:1-4 259 1 0.0 0.0 0.0 0.0
- res.xs Main Main.hs:47:8-69 260 1 0.0 0.0 0.0 0.0
- clauses Main Main.hs:68:1-74 262 0 0.0 0.0 100.0 99.9
- disin Main Main.hs:(74,1)-(83,11) 267 857598 29.4 49.5 41.2 49.5
- conjunct Main Main.hs:(70,1)-(71,18) 291 759353 10.6 0.0 10.6 0.0
- disin.dp Main Main.hs:80:3-14 292 380009 1.2 0.0 1.2 0.0
- disin.dq Main Main.hs:81:3-14 293 380009 0.0 0.0 0.0 0.0
- negin Main Main.hs:(119,1)-(124,11) 268 1617 0.0 0.1 0.0 0.1
- elim Main Main.hs:(89,1)-(94,57) 269 1393 0.0 0.1 0.0 0.1
- disp Main Main.hs:86:1-71 301 7 0.0 0.0 0.0 0.0
- interleave Main Main.hs:(115,1)-(116,25) 302 35 0.0 0.0 0.0 0.0
- parse Main Main.hs:135:1-39 270 7 0.0 0.0 0.0 0.0
- parse.(...) Main Main.hs:135:19-39 272 7 0.0 0.0 0.0 0.0
- parse' Main Main.hs:(137,1)-(145,42) 273 280 0.0 0.0 0.0 0.0
- opri Main Main.hs:(127,1)-(132,12) 276 56 0.0 0.0 0.0 0.0
- spri Main Main.hs:(169,1)-(170,10) 274 56 0.0 0.0 0.0 0.0
- opri Main Main.hs:(127,1)-(132,12) 275 49 0.0 0.0 0.0 0.0
- parse'.(...) Main Main.hs:142:20-49 278 21 0.0 0.0 0.0 0.0
- redstar Main Main.hs:155:1-35 280 0 0.0 0.0 0.0 0.0
- spri Main Main.hs:(169,1)-(170,10) 282 63 0.0 0.0 0.0 0.0
- opri Main Main.hs:(127,1)-(132,12) 283 63 0.0 0.0 0.0 0.0
- while Main Main.hs:182:1-48 281 63 0.0 0.0 0.0 0.0
- red Main Main.hs:(148,1)-(152,43) 284 42 0.0 0.0 0.0 0.0
- parse'.s' Main Main.hs:142:20-49 285 21 0.0 0.0 0.0 0.0
- parse'.x Main Main.hs:142:20-49 277 21 0.0 0.0 0.0 0.0
- redstar Main Main.hs:155:1-35 286 0 0.0 0.0 0.0 0.0
- spri Main Main.hs:(169,1)-(170,10) 288 21 0.0 0.0 0.0 0.0
- opri Main Main.hs:(127,1)-(132,12) 289 14 0.0 0.0 0.0 0.0
- while Main Main.hs:182:1-48 287 21 0.0 0.0 0.0 0.0
- red Main Main.hs:(148,1)-(152,43) 290 14 0.0 0.0 0.0 0.0
- parse.f Main Main.hs:135:19-39 271 7 0.0 0.0 0.0 0.0
- split Main Main.hs:(163,1)-(166,28) 265 7 0.0 0.0 2.4 2.3
- split.split' Main Main.hs:(165,11)-(166,28) 266 74837 2.4 2.3 2.4 2.3
- unicl Main Main.hs:(176,1)-(180,36) 264 7 0.0 1.1 56.5 48.0
- unicl.unicl' Main Main.hs:(178,11)-(180,36) 294 37422 3.5 2.6 56.5 46.9
- tautclause Main Main.hs:173:1-49 295 37422 4.7 3.7 4.7 3.7
- unicl.unicl'.cp Main Main.hs:180:24-36 296 37422 0.0 0.0 48.2 40.6
- clause Main Main.hs:(61,1)-(65,57) 297 37422 0.0 1.4 48.2 40.6
- clause.clause' Main Main.hs:(63,12)-(65,57) 298 696150 23.5 37.5 48.2 39.2
- insert Main Main.hs:(108,1)-(112,8) 299 366786 24.7 1.7 24.7 1.7
- insert Main Main.hs:(108,1)-(112,8) 300 7 0.0 0.0 0.0 0.0
+MAIN MAIN <built-in> 137 0 0.0 0.0 100.0 100.0
+ CAF Main <entire-module> 273 0 0.0 0.0 0.0 0.0
+ clauses Main Main.hs:68:1-74 280 1 0.0 0.0 0.0 0.0
+ Main.clauses(calling:Data.Foldable.concat) Main Main.hs:68:1-7 282 1 0.0 0.0 0.0 0.0
+ main Main Main.hs:(42,1)-(44,23) 274 1 0.0 0.0 0.0 0.0
+ redstar Main Main.hs:155:1-35 298 1 0.0 0.0 0.0 0.0
+ spaces Main Main.hs:160:1-19 322 1 0.0 0.0 0.0 0.0
+ CAF GHC.Conc.Signal <entire-module> 251 0 0.0 0.0 0.0 0.0
+ CAF GHC.IO.Encoding <entire-module> 232 0 0.0 0.0 0.0 0.0
+ CAF GHC.IO.Encoding.Iconv <entire-module> 230 0 0.0 0.0 0.0 0.0
+ CAF GHC.IO.Handle.FD <entire-module> 221 0 0.0 0.0 0.0 0.0
+ main Main Main.hs:(42,1)-(44,23) 275 0 0.0 0.0 100.0 100.0
+ main.\ Main Main.hs:44:3-23 276 1 0.0 0.0 100.0 100.0
+ res Main Main.hs:(46,1)-(48,26) 277 1 0.0 0.0 100.0 99.9
+ Main.main(calling:Data.Foldable.concat) Main Main.hs:42:1-4 278 1 0.0 0.0 0.0 0.0
+ res.xs Main Main.hs:47:8-69 279 1 0.0 0.0 0.0 0.0
+ clauses Main Main.hs:68:1-74 281 0 0.0 0.0 100.0 99.9
+ disin Main Main.hs:(74,1)-(83,11) 286 857598 29.8 49.8 39.4 49.8
+ conjunct Main Main.hs:(70,1)-(71,18) 310 759353 8.2 0.0 8.2 0.0
+ disin.dp Main Main.hs:80:3-14 311 380009 1.0 0.0 1.0 0.0
+ disin.dq Main Main.hs:81:3-14 312 380009 0.5 0.0 0.5 0.0
+ negin Main Main.hs:(119,1)-(124,11) 287 1617 0.0 0.1 0.0 0.1
+ elim Main Main.hs:(89,1)-(94,57) 288 1393 0.0 0.1 0.0 0.1
+ disp Main Main.hs:86:1-71 320 7 0.0 0.0 0.0 0.0
+ interleave Main Main.hs:(115,1)-(116,25) 321 35 0.0 0.0 0.0 0.0
+ parse Main Main.hs:135:1-39 289 7 0.0 0.0 0.0 0.0
+ parse.(...) Main Main.hs:135:19-39 291 7 0.0 0.0 0.0 0.0
+ parse' Main Main.hs:(137,1)-(145,42) 292 280 0.0 0.0 0.0 0.0
+ opri Main Main.hs:(127,1)-(132,12) 295 56 0.0 0.0 0.0 0.0
+ spri Main Main.hs:(169,1)-(170,10) 293 56 0.0 0.0 0.0 0.0
+ opri Main Main.hs:(127,1)-(132,12) 294 49 0.0 0.0 0.0 0.0
+ parse'.(...) Main Main.hs:142:20-49 297 21 0.0 0.0 0.0 0.0
+ redstar Main Main.hs:155:1-35 299 0 0.0 0.0 0.0 0.0
+ spri Main Main.hs:(169,1)-(170,10) 301 63 0.0 0.0 0.0 0.0
+ opri Main Main.hs:(127,1)-(132,12) 302 63 0.0 0.0 0.0 0.0
+ while Main Main.hs:182:1-48 300 63 0.0 0.0 0.0 0.0
+ red Main Main.hs:(148,1)-(152,43) 303 42 0.0 0.0 0.0 0.0
+ parse'.s' Main Main.hs:142:20-49 304 21 0.0 0.0 0.0 0.0
+ parse'.x Main Main.hs:142:20-49 296 21 0.0 0.0 0.0 0.0
+ redstar Main Main.hs:155:1-35 305 0 0.0 0.0 0.0 0.0
+ spri Main Main.hs:(169,1)-(170,10) 307 21 0.0 0.0 0.0 0.0
+ opri Main Main.hs:(127,1)-(132,12) 308 14 0.0 0.0 0.0 0.0
+ while Main Main.hs:182:1-48 306 21 0.0 0.0 0.0 0.0
+ red Main Main.hs:(148,1)-(152,43) 309 14 0.0 0.0 0.0 0.0
+ parse.f Main Main.hs:135:19-39 290 7 0.0 0.0 0.0 0.0
+ split Main Main.hs:(163,1)-(166,28) 284 7 0.0 0.0 1.4 2.3
+ split.split' Main Main.hs:(165,11)-(166,28) 285 74837 1.4 2.3 1.4 2.3
+ unicl Main Main.hs:(176,1)-(180,36) 283 7 0.5 1.1 59.1 47.7
+ unicl.unicl' Main Main.hs:(178,11)-(180,36) 313 37422 1.4 2.0 58.7 46.6
+ tautclause Main Main.hs:173:1-49 314 37422 5.8 3.7 5.8 3.7
+ unicl.unicl'.cp Main Main.hs:180:24-36 315 37422 0.0 0.0 51.4 40.9
+ clause Main Main.hs:(61,1)-(65,57) 316 37422 0.0 1.4 51.4 40.9
+ clause.clause' Main Main.hs:(63,12)-(65,57) 317 696150 22.6 37.7 51.4 39.5
+ insert Main Main.hs:(108,1)-(112,8) 318 366786 28.8 1.7 28.8 1.7
+ insert Main Main.hs:(108,1)-(112,8) 319 7 0.0 0.0 0.0 0.0
diff --git a/testsuite/tests/profiling/should_run/callstack001.stdout b/testsuite/tests/profiling/should_run/callstack001.stdout
index 13c64a0a758990e19686bcd1f32387ce5c894b9a..78d483cfecb0d1957acca95da131009e8de787cf 100644
--- a/testsuite/tests/profiling/should_run/callstack001.stdout
+++ b/testsuite/tests/profiling/should_run/callstack001.stdout
@@ -1,2 +1,2 @@
-["Main.main (callstack001.hs:17:8-21)","Main.mapM (callstack001.hs:10:13-17)","Main.mapM.go (callstack001.hs:13:17-19)","Main.f (callstack001.hs:7:10-35)"]
-["Main.main (callstack001.hs:17:8-21)","Main.mapM (callstack001.hs:10:13-17)","Main.mapM.go (callstack001.hs:13:17-19)","Main.f (callstack001.hs:7:10-35)"]
+["Main.main (callstack001.hs:17:8-21)","Main.mapM (callstack001.hs:10:13-17)","Main.mapM.go (callstack001.hs:(12,21)-(15,25))","Main.mapM.go (callstack001.hs:13:17-19)","Main.f (callstack001.hs:7:7-49)","Main.f (callstack001.hs:7:10-35)"]
+["Main.main (callstack001.hs:17:8-21)","Main.mapM (callstack001.hs:10:13-17)","Main.mapM.go (callstack001.hs:(12,21)-(15,25))","Main.mapM.go (callstack001.hs:14:11-26)","Main.mapM.go (callstack001.hs:13:17-19)","Main.f (callstack001.hs:7:7-49)","Main.f (callstack001.hs:7:10-35)"]
diff --git a/testsuite/tests/rebindable/T23147.hs b/testsuite/tests/rebindable/T23147.hs
new file mode 100644
index 0000000000000000000000000000000000000000..7db1c3ff878d7159c3d3cdce6b62a71674599417
--- /dev/null
+++ b/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)
diff --git a/testsuite/tests/rebindable/all.T b/testsuite/tests/rebindable/all.T
index b5123102e93bba04af966f18331b421bec3c35d7..f6040af21dcfc71a141e0716139dfcb095872527 100644
--- a/testsuite/tests/rebindable/all.T
+++ b/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 expanding do before typechecking
+test('T23147', normal, compile, [''])
+test('pattern-fails', normal, compile_and_run, [''])
+test('simple-rec', normal, compile_and_run, [''])
diff --git a/testsuite/tests/rebindable/pattern-fails.hs b/testsuite/tests/rebindable/pattern-fails.hs
new file mode 100644
index 0000000000000000000000000000000000000000..27b111798fbd093cf43361589b05166c59efd421
--- /dev/null
+++ b/testsuite/tests/rebindable/pattern-fails.hs
@@ -0,0 +1,17 @@
+module Main 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)
+
+ppp :: Maybe (ST Int Int) -> Maybe (ST Int Int)
+ppp st = do { ST (x, y) <- st
+ ; return $ ST (x+1, y+1)}
+
+
diff --git a/testsuite/tests/rebindable/pattern-fails.stdout b/testsuite/tests/rebindable/pattern-fails.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..4a584e4989262b5560db8504e40e2dcb591c6edf
--- /dev/null
+++ b/testsuite/tests/rebindable/pattern-fails.stdout
@@ -0,0 +1 @@
+Nothing
diff --git a/testsuite/tests/rebindable/rebindable6.stderr b/testsuite/tests/rebindable/rebindable6.stderr
index 61cb0d9775cf9be584945daae411ad3e28aab160..c9d35ac263f218fa3e19ad3af2f203651b8c14fe 100644
--- a/testsuite/tests/rebindable/rebindable6.stderr
+++ b/testsuite/tests/rebindable/rebindable6.stderr
@@ -25,15 +25,15 @@ rebindable6.hs:110:17: error: [GHC-39999]
return b
rebindable6.hs:111:17: error: [GHC-39999]
- • Ambiguous type variables ‘p0’, ‘t0’ arising from a do statement
+ • Ambiguous type variables ‘t1’, ‘t0’ arising from a do statement
prevents the constraint ‘(HasBind
- (IO (Maybe b) -> (Maybe b -> p0) -> t0))’ from being solved.
+ (IO (Maybe b) -> (Maybe b -> t1) -> t0))’ from being solved.
(maybe you haven't applied a function to enough arguments?)
Relevant bindings include
g :: IO (Maybe b) (bound at rebindable6.hs:108:19)
test_do :: IO a -> IO (Maybe b) -> IO b
(bound at rebindable6.hs:108:9)
- Probable fix: use a type annotation to specify what ‘p0’,
+ Probable fix: use a type annotation to specify what ‘t1’,
‘t0’ should be.
Potentially matching instance:
instance HasBind (IO a -> (a -> IO b) -> IO b)
@@ -50,15 +50,15 @@ rebindable6.hs:111:17: error: [GHC-39999]
return b
rebindable6.hs:112:17: error: [GHC-39999]
- • Ambiguous type variable ‘p0’ arising from a use of ‘return’
- prevents the constraint ‘(HasReturn (b -> p0))’ from being solved.
+ • Ambiguous type variable ‘t1’ arising from a use of ‘return’
+ prevents the constraint ‘(HasReturn (b -> t1))’ from being solved.
(maybe you haven't applied a function to enough arguments?)
Relevant bindings include
b :: b (bound at rebindable6.hs:111:23)
g :: IO (Maybe b) (bound at rebindable6.hs:108:19)
test_do :: IO a -> IO (Maybe b) -> IO b
(bound at rebindable6.hs:108:9)
- Probable fix: use a type annotation to specify what ‘p0’ should be.
+ Probable fix: use a type annotation to specify what ‘t1’ should be.
Potentially matching instance:
instance HasReturn (a -> IO a) -- Defined at rebindable6.hs:46:18
• In a stmt of a 'do' block: return b
diff --git a/testsuite/tests/rebindable/simple-rec.hs b/testsuite/tests/rebindable/simple-rec.hs
new file mode 100644
index 0000000000000000000000000000000000000000..8f4c3309c4013de796c4663d761b96e332e7717e
--- /dev/null
+++ b/testsuite/tests/rebindable/simple-rec.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE RecursiveDo #-}
+module Main where
+
+
+blah x y = return (3::Int)
+
+main = do -- x <- foo1
+ rec { y <- blah x y
+ ; x <- blah x y
+ }
+ putStrLn $ show x
diff --git a/testsuite/tests/rebindable/simple-rec.stdout b/testsuite/tests/rebindable/simple-rec.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..00750edc07d6415dcc07ae0351e9397b0222b7ba
--- /dev/null
+++ b/testsuite/tests/rebindable/simple-rec.stdout
@@ -0,0 +1 @@
+3
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr
index bb604e5243de2ba680aa4ee9c552a68f678e5fba..4813ea3d3d80d1b0bcda1368c81dabd6da6b4e7e 100644
--- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr
@@ -14,7 +14,4 @@ SafeLang10.hs:9:13: error: [GHC-36705]
instance Pos [a] -- Defined at SafeLang10_A.hs:14:10
• In the expression: res [(1 :: Int)]
In an equation for ‘r’: r = res [(1 :: Int)]
- In the expression:
- do let r = res ...
- putStrLn $ "Result: " ++ show r
- putStrLn $ "Result: " ++ show function
+ In a stmt of a 'do' block: let r = res [(1 :: Int)]
diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr
index ab59ebff30022424c324501e82c2955b40f6f45f..4b2219a1f878152283b1d046f30223c64c8e5144 100644
--- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr
+++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr
@@ -14,7 +14,4 @@ SafeLang17.hs:9:13: error: [GHC-36705]
instance Pos [a] -- Defined at SafeLang17_A.hs:14:10
• In the expression: res [(1 :: Int)]
In an equation for ‘r’: r = res [(1 :: Int)]
- In the expression:
- do let r = res ...
- putStrLn $ "Result: " ++ show r
- putStrLn $ "Result: " ++ show function
+ In a stmt of a 'do' block: let r = res [(1 :: Int)]
diff --git a/testsuite/tests/simplCore/should_compile/simpl017.stderr b/testsuite/tests/simplCore/should_compile/simpl017.stderr
index 9aae96949f525a59be82a5a0ccf5fd3bf1c70656..949806908f6e8a0a704b6ae2590df948f4911868 100644
--- a/testsuite/tests/simplCore/should_compile/simpl017.stderr
+++ b/testsuite/tests/simplCore/should_compile/simpl017.stderr
@@ -23,24 +23,3 @@ simpl017.hs:55:5: error: [GHC-83865]
a :: arr i a (bound at simpl017.hs:50:11)
liftArray :: arr i a -> E m (forall v. [E m i] -> E' v m a)
(bound at simpl017.hs:50:1)
-
-simpl017.hs:71:10: error: [GHC-83865]
- • Couldn't match type: forall v. [E (ST s) Int] -> E' v (ST s) Int
- with: [E (ST t0) Int] -> E (ST s) Int
- Expected: E' RValue (ST s) ([E (ST t0) Int] -> E (ST s) Int)
- Actual: E (ST s) (forall v. [E (ST s) Int] -> E' v (ST s) Int)
- • In a stmt of a 'do' block: a <- liftArray ma
- In the second argument of ‘($)’, namely
- ‘do a <- liftArray ma
- let one :: E (ST t) Int
- one = return 1
- a [one] `plus` a [one]’
- In the expression:
- runE
- $ do a <- liftArray ma
- let one :: E (ST t) Int
- one = return 1
- a [one] `plus` a [one]
- • Relevant bindings include
- ma :: STArray s Int Int (bound at simpl017.hs:70:5)
- foo :: STArray s Int Int -> ST s Int (bound at simpl017.hs:70:1)
diff --git a/testsuite/tests/typecheck/should_compile/T21206.hs b/testsuite/tests/typecheck/should_compile/T21206.hs
new file mode 100644
index 0000000000000000000000000000000000000000..9178d7fe49e036417916e69c43ea56a03e71c815
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T21206.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE QualifiedDo #-}
+module T where
+
+import Prelude hiding (pure, (>>=))
+
+data Free f u a
+ = Pure (u a)
+ | forall x. Free (f u x) (forall u'. u <= u' => u' x -> Free f u' x)
+
+pure :: u a -> Free f u a
+pure = Pure
+(>>=) :: Free f u a -> (forall u'. u <= u' => u' a -> Free f u' a) -> Free f u a
+Pure x >>= k = k x
+
+class f < g where
+ inj :: f u a -> g u a
+
+class u <= u' where
+ inj' :: u a -> u' a
+
+instance u <= u where
+ inj' = id
+
+send :: (f < g) => f u a -> Free g u a
+send op = Free (inj op) Pure
+
+data State s u a where
+ Get :: State s u s
+ Put :: u s -> State s u ()
+
+prog () = T.do
+ x <- send Get
+ Pure x
diff --git a/testsuite/tests/typecheck/should_compile/T22788.hs b/testsuite/tests/typecheck/should_compile/T22788.hs
new file mode 100644
index 0000000000000000000000000000000000000000..03dc84701d17b5f34ce36d0165188ebeea930261
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T22788.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE QualifiedDo #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
+
+module E where
+
+import Data.Data (Typeable)
+import Data.Kind (Type)
+
+infixr 0 ~>
+type f ~> g = forall x. f x -> g x
+
+class IFunctor f where
+ imap :: (a ~> b) -> f a ~> f b
+
+class IFunctor f => IApplicative f where
+ ireturn :: a ~> f a
+
+class IApplicative m => IMonad m where
+ ibind :: (a ~> m b) -> m a ~> m b
+
+class IMonad m => IMonadFail m where
+ fail :: String -> m a ix
+
+data At :: Type -> k -> k -> Type where
+ At :: a -> At a k k
+ deriving (Typeable)
+
+(>>=) :: IMonad (m :: (x -> Type) -> x -> Type) => m a ix -> (a ~> m b) -> m b ix
+m >>= f = ibind f m
+
+data FHState = FOpen | FClosed
+
+data FHSTATE :: FHState -> Type where
+ FOPEN :: FHSTATE FOpen
+ FCLOSED :: FHSTATE FClosed
+
+data FH :: (FHState -> Type) -> FHState -> Type where
+ FHReturn :: q i -> FH q i
+ FHOpen :: FilePath -> (FHSTATE ~> FH q) -> FH q FClosed
+ FHClose :: FH q FClosed -> FH q FOpen
+ FHRead :: (Maybe Char -> FH q FOpen) -> FH q FOpen
+ FHIO :: IO () -> FH q i -> FH q i
+
+instance IFunctor FH where
+ imap f (FHReturn q) = FHReturn (f q)
+ imap f (FHOpen s k) = FHOpen s (imap f . k)
+ imap f (FHClose q) = FHClose (imap f q)
+ imap f (FHRead k) = FHRead (imap f . k)
+ imap f (FHIO io k) = FHIO io (imap f k)
+
+instance IApplicative FH where
+ ireturn = FHReturn
+
+instance IMonad FH where
+ ibind f (FHReturn q) = f q
+ ibind f (FHOpen fp p) = FHOpen fp (ibind f . p)
+ ibind f (FHClose q) = FHClose (ibind f q)
+ ibind f (FHRead f') = FHRead (ibind f . f')
+ ibind f (FHIO io f') = FHIO io (ibind f f')
+
+fhOpen :: FilePath -> FH FHSTATE 'FClosed
+fhOpen f = FHOpen f FHReturn
+
+fhClose :: FH (At () 'FClosed) 'FOpen
+fhClose = FHClose . FHReturn $ At ()
+
+fhio :: IO () -> FH (At () i) i
+fhio io = FHIO io . FHReturn $ At ()
+
+----------------------right function -------------------------------
+rightFun :: FilePath -> FH (At () FClosed) FClosed
+rightFun fp =
+ fhio (print fp)
+ E.>>= ( \(At _) -> E.do
+ fhOpen fp E.>>= \case
+ FCLOSED -> FHReturn (At ())
+ FOPEN -> E.do
+ At _ <- fhClose
+ FHReturn (At ())
+ )
+
+----------------------bug function -------------------------------
+errorFun :: FilePath -> FH (At () FClosed) FClosed
+errorFun fp = E.do
+ At _ <- fhio (print fp)
+ foState <- fhOpen fp
+ case foState of
+ FCLOSED -> FHReturn (At ())
+ FOPEN -> E.do
+ At _ <- fhClose
+ FHReturn (At ())
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 135c22c619664560cbdb1c2d9dc882ba974873ee..b0e6bed3a87c270e0aa0e8bf4e0f48e4474c3674 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -907,3 +907,5 @@ test('T23861', normal, compile, [''])
test('T23918', normal, compile, [''])
test('T17564', normal, compile, [''])
test('T24146', normal, compile, [''])
+test('T22788', normal, compile, [''])
+test('T21206', normal, compile, [''])
\ No newline at end of file
diff --git a/testsuite/tests/typecheck/should_fail/DoExpansion1.hs b/testsuite/tests/typecheck/should_fail/DoExpansion1.hs
new file mode 100644
index 0000000000000000000000000000000000000000..554ede86047b94f6abdf819c5670bbcee4255c2d
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/DoExpansion1.hs
@@ -0,0 +1,32 @@
+module DoExpansion1 where
+
+
+-- Ensure that >> expansions work okay
+
+qqqqq1 :: IO ()
+qqqqq1 = putStrLn 1 >> putStrLn "q2" >> putStrLn "q3" -- this should error as "In the first argument to >>"
+
+
+qqqqq2 :: IO ()
+qqqqq2 = (putStrLn "q1" >> putStrLn 2) >> putStrLn "q3" -- this should error as "In first argument to >>
+ -- In second argument to >>"
+
+qqqqq3 :: IO ()
+qqqqq3 = putStrLn "q1" >> (putStrLn "q2" >> putStrLn 3) -- this should error as "In second argument to >>
+ -- In second argument to >>"
+
+rrrr1 :: IO ()
+rrrr1 = do putStrLn 1 -- this should error as "In the stmt of a do block"
+ putStrLn "r2"
+ putStrLn "r3"
+
+rrrr2 :: IO ()
+rrrr2 = do putStrLn "r1"
+ putStrLn 2 -- this should error as "In the stmt of a do block"
+ putStrLn "r3"
+
+
+rrrr3 :: IO ()
+rrrr3 = do putStrLn "r1"
+ putStrLn "r2"
+ putStrLn 3 -- this should error as "In the stmt of a do block"
diff --git a/testsuite/tests/typecheck/should_fail/DoExpansion1.stderr b/testsuite/tests/typecheck/should_fail/DoExpansion1.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..fc1f63023b30d5008ed2e6f14c9a30c805059962
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/DoExpansion1.stderr
@@ -0,0 +1,48 @@
+
+DoExpansion1.hs:7:19: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
+ • No instance for ‘Num String’ arising from the literal ‘1’
+ • In the first argument of ‘putStrLn’, namely ‘1’
+ In the first argument of ‘(>>)’, namely ‘putStrLn 1’
+ In the first argument of ‘(>>)’, namely
+ ‘putStrLn 1 >> putStrLn "q2"’
+
+DoExpansion1.hs:11:37: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
+ • No instance for ‘Num String’ arising from the literal ‘2’
+ • In the first argument of ‘putStrLn’, namely ‘2’
+ In the second argument of ‘(>>)’, namely ‘putStrLn 2’
+ In the first argument of ‘(>>)’, namely
+ ‘(putStrLn "q1" >> putStrLn 2)’
+
+DoExpansion1.hs:15:54: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
+ • No instance for ‘Num String’ arising from the literal ‘3’
+ • In the first argument of ‘putStrLn’, namely ‘3’
+ In the second argument of ‘(>>)’, namely ‘putStrLn 3’
+ In the second argument of ‘(>>)’, namely
+ ‘(putStrLn "q2" >> putStrLn 3)’
+
+DoExpansion1.hs:19:21: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
+ • No instance for ‘Num String’ arising from the literal ‘1’
+ • In the first argument of ‘putStrLn’, namely ‘1’
+ In a stmt of a 'do' block: putStrLn 1
+ In the expression:
+ do putStrLn 1
+ putStrLn "r2"
+ putStrLn "r3"
+
+DoExpansion1.hs:25:21: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
+ • No instance for ‘Num String’ arising from the literal ‘2’
+ • In the first argument of ‘putStrLn’, namely ‘2’
+ In a stmt of a 'do' block: putStrLn 2
+ In the expression:
+ do putStrLn "r1"
+ putStrLn 2
+ putStrLn "r3"
+
+DoExpansion1.hs:32:21: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)]
+ • No instance for ‘Num String’ arising from the literal ‘3’
+ • In the first argument of ‘putStrLn’, namely ‘3’
+ In a stmt of a 'do' block: putStrLn 3
+ In the expression:
+ do putStrLn "r1"
+ putStrLn "r2"
+ putStrLn 3
diff --git a/testsuite/tests/typecheck/should_fail/DoExpansion2.hs b/testsuite/tests/typecheck/should_fail/DoExpansion2.hs
new file mode 100644
index 0000000000000000000000000000000000000000..9f36b8e584972b245edaf8a0ab3352a68a29463b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/DoExpansion2.hs
@@ -0,0 +1,39 @@
+module DoExpansion2 where
+
+
+-- make sure all the (>>=) expansion works okay
+
+getVal :: Int -> IO String
+getVal _ = return "x"
+
+ffff1, ffff2, ffff3, ffff4, ffff5, ffff6, ffff7, ffff8 :: IO Int
+
+
+ffff1 = do x <- getChar
+ return (x + 1) -- should error here
+
+ffff2 = do x <- (getVal 3)
+ return x -- should error here
+
+ffff3 = do x <- getChar
+ y <- getChar
+ return (x + y) -- should error here
+
+ffff4 = do Just x <- getChar -- should error here
+ return x
+
+
+ffff5 = do x <- getChar
+ Just x <- getChar -- should error here
+ return x
+
+ffff6 = do _ <- (getVal 1)
+ return () -- should error here
+
+
+ffff7 = do Just x <- getVal 3 4 -- should error here
+ return x
+
+
+ffff8 = do x <- getVal 3
+ return x -- should error here
diff --git a/testsuite/tests/typecheck/should_fail/DoExpansion2.stderr b/testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..044fb871169b20b51b08cbf56f27e54190ade64c
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
@@ -0,0 +1,73 @@
+
+DoExpansion2.hs:13:20: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type ‘Int’ with actual type ‘Char’
+ • In the first argument of ‘(+)’, namely ‘x’
+ In the first argument of ‘return’, namely ‘(x + 1)’
+ In a stmt of a 'do' block: return (x + 1)
+
+DoExpansion2.hs:16:19: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match type ‘[Char]’ with ‘Int’
+ Expected: Int
+ Actual: String
+ • In the first argument of ‘return’, namely ‘x’
+ In a stmt of a 'do' block: return x
+ In the expression:
+ do x <- (getVal 3)
+ return x
+
+DoExpansion2.hs:20:20: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type ‘Int’ with actual type ‘Char’
+ • In the first argument of ‘(+)’, namely ‘x’
+ In the first argument of ‘return’, namely ‘(x + y)’
+ In a stmt of a 'do' block: return (x + y)
+
+DoExpansion2.hs:20:24: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type ‘Int’ with actual type ‘Char’
+ • In the second argument of ‘(+)’, namely ‘y’
+ In the first argument of ‘return’, namely ‘(x + y)’
+ In a stmt of a 'do' block: return (x + y)
+
+DoExpansion2.hs:22:12: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type ‘Char’ with actual type ‘Maybe Int’
+ • In the pattern: Just x
+ In a stmt of a 'do' block: Just x <- getChar
+ In the expression:
+ do Just x <- getChar
+ return x
+
+DoExpansion2.hs:27:12: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type ‘Char’ with actual type ‘Maybe Int’
+ • In the pattern: Just x
+ In a stmt of a 'do' block: Just x <- getChar
+ In the expression:
+ do x <- getChar
+ Just x <- getChar
+ return x
+
+DoExpansion2.hs:31:19: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type ‘Int’ with actual type ‘()’
+ • In the first argument of ‘return’, namely ‘()’
+ In a stmt of a 'do' block: return ()
+ In the expression:
+ do _ <- (getVal 1)
+ return ()
+
+DoExpansion2.hs:34:22: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type: t0 -> IO (Maybe Int)
+ with actual type: IO String
+ • The function ‘getVal’ is applied to two value arguments,
+ but its type ‘Int -> IO String’ has only one
+ In a stmt of a 'do' block: Just x <- getVal 3 4
+ In the expression:
+ do Just x <- getVal 3 4
+ return x
+
+DoExpansion2.hs:39:19: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match type ‘[Char]’ with ‘Int’
+ Expected: Int
+ Actual: String
+ • In the first argument of ‘return’, namely ‘x’
+ In a stmt of a 'do' block: return x
+ In the expression:
+ do x <- getVal 3
+ return x
diff --git a/testsuite/tests/typecheck/should_fail/DoExpansion3.hs b/testsuite/tests/typecheck/should_fail/DoExpansion3.hs
new file mode 100644
index 0000000000000000000000000000000000000000..97711826feb7eb45fe0c5f802767ea3bfc4ec977
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/DoExpansion3.hs
@@ -0,0 +1,33 @@
+module DoExpansion3 where
+
+
+-- make sure all the (>>=) expansion works okay
+
+getVal :: Int -> IO String
+getVal _ = return "x"
+
+gggg1, gggg2, gggg3, gggg4, gggg5 :: IO Int
+
+
+gggg1 = do let x = 1
+ let y = 2
+ putStrLn x -- should error here
+ return (x + 1)
+
+gggg2 = do let x = 1
+ y = getChar 2 -- should error here
+ z = 3
+ return x
+
+gggg3 = do x <- getChar
+ let y = 2
+ z <- getChar
+ return (x + y) -- should error here
+
+gggg4 = do Just x <- getChar -- should error here
+ return x
+
+gggg5 = do
+ let z :: Int = 3
+ let a = 1
+ putStrLn $ a + ""
diff --git a/testsuite/tests/typecheck/should_fail/DoExpansion3.stderr b/testsuite/tests/typecheck/should_fail/DoExpansion3.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..1dd19692edb44d1d1520ba893c953e192c0bc817
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/DoExpansion3.stderr
@@ -0,0 +1,46 @@
+
+DoExpansion3.hs:15:20: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match type ‘[Char]’ with ‘Int’
+ Expected: Int
+ Actual: String
+ • In the first argument of ‘(+)’, namely ‘x’
+ In the first argument of ‘return’, namely ‘(x + 1)’
+ In a stmt of a 'do' block: return (x + 1)
+
+DoExpansion3.hs:18:20: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type: t0 -> t
+ with actual type: IO Char
+ • The function ‘getChar’ is applied to one value argument,
+ but its type ‘IO Char’ has none
+ In the expression: getChar 2
+ In an equation for ‘y’: y = getChar 2
+ • Relevant bindings include y :: t (bound at DoExpansion3.hs:18:16)
+
+DoExpansion3.hs:25:20: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type ‘Int’ with actual type ‘Char’
+ • In the first argument of ‘(+)’, namely ‘x’
+ In the first argument of ‘return’, namely ‘(x + y)’
+ In a stmt of a 'do' block: return (x + y)
+
+DoExpansion3.hs:27:12: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type ‘Char’ with actual type ‘Maybe Int’
+ • In the pattern: Just x
+ In a stmt of a 'do' block: Just x <- getChar
+ In the expression:
+ do Just x <- getChar
+ return x
+
+DoExpansion3.hs:33:3: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match type ‘()’ with ‘Int’
+ Expected: IO Int
+ Actual: IO ()
+ • In a stmt of a 'do' block: putStrLn $ a + ""
+ In the expression:
+ do let z :: Int = 3
+ let a = 1
+ putStrLn $ a + ""
+ In an equation for ‘gggg5’:
+ gggg5
+ = do let z :: Int = ...
+ let a = ...
+ putStrLn $ a + ""
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index e4bb647ee06d80c0f38e6d1aae8c20d02610eaac..fa90f912fa44d6fca45395f30cbcb6bea544bb06 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -146,7 +146,7 @@ test('tcfail160', normal, compile_fail, [''])
test('tcfail161', normal, compile_fail, [''])
test('tcfail162', normal, compile_fail, [''])
test('tcfail164', normal, compile_fail, [''])
-test('tcfail165', normal, compile_fail, [''])
+test('tcfail165', normal, compile, [''])
test('tcfail166', normal, compile_fail, [''])
test('tcfail167', normal, compile_fail, ['-Werror'])
test('tcfail168', normal, compile_fail, [''])
@@ -712,3 +712,8 @@ test('ErrorIndexLinks', normal, compile_fail, ['-fprint-error-index-links=always
test('T24064', normal, compile_fail, [''])
test('T24298', normal, compile_fail, [''])
test('T24279', normal, compile_fail, [''])
+
+# all the various do expansion fail messages
+test('DoExpansion1', normal, compile, ['-fdefer-type-errors'])
+test('DoExpansion2', normal, compile, ['-fdefer-type-errors'])
+test('DoExpansion3', normal, compile, ['-fdefer-type-errors'])
diff --git a/testsuite/tests/typecheck/should_fail/tcfail165.hs b/testsuite/tests/typecheck/should_fail/tcfail165.hs
index 11c016b08b9ffcdd64a946120c8c89a7d9abb16b..a9af49a7a4ffb8fa1b05188d42fd16a165505807 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail165.hs
+++ b/testsuite/tests/typecheck/should_fail/tcfail165.hs
@@ -14,6 +14,8 @@ import Control.Concurrent
-- With the Visible Type Application patch, this succeeds again.
--
-- Sept 16: fails again as it should
+--
+-- DoExpansion makes it pass again. RAE says this should typecheck
foo = do var <- newEmptyMVar :: IO (MVar (forall a. Show a => a -> String))
putMVar var (show :: forall b. Show b => b -> String)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail165.stderr b/testsuite/tests/typecheck/should_fail/tcfail165.stderr
deleted file mode 100644
index 73c7d70d570856babe7226c29d78f222c7268d1f..0000000000000000000000000000000000000000
--- a/testsuite/tests/typecheck/should_fail/tcfail165.stderr
+++ /dev/null
@@ -1,17 +0,0 @@
-
-tcfail165.hs:18:17: error: [GHC-83865]
- • Couldn't match type: forall a. Show a => a -> String
- with: b0 -> String
- Expected: IO (MVar (b0 -> String))
- Actual: IO (MVar (forall a. Show a => a -> String))
- • In a stmt of a 'do' block:
- var <- newEmptyMVar :: IO (MVar (forall a. Show a => a -> String))
- In the expression:
- do var <- newEmptyMVar ::
- IO (MVar (forall a. Show a => a -> String))
- putMVar var (show :: forall b. Show b => b -> String)
- In an equation for ‘foo’:
- foo
- = do var <- newEmptyMVar ::
- IO (MVar (forall a. Show a => a -> String))
- putMVar var (show :: forall b. Show b => b -> String)
diff --git a/testsuite/tests/typecheck/should_run/T15598.hs b/testsuite/tests/typecheck/should_run/T15598.hs
new file mode 100644
index 0000000000000000000000000000000000000000..e25218abd2e8b7f3ed0d6c483896a7965f8585f9
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T15598.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE
+ GADTSyntax
+ , RankNTypes
+ , RebindableSyntax
+#-}
+
+import Prelude hiding ((>>=))
+
+data InfDo where
+ InfDo :: String -> (forall a. a -> InfDo) -> InfDo
+
+prog :: InfDo
+prog = do
+ _ <- show (42 :: Int)
+ prog
+ where
+ (>>=) = InfDo
+
+main :: IO ()
+main = let x = prog in x `seq` return ()
diff --git a/testsuite/tests/typecheck/should_run/T18324.hs b/testsuite/tests/typecheck/should_run/T18324.hs
new file mode 100644
index 0000000000000000000000000000000000000000..35390392473df1645b43f3bd4b106ac7a1fb8ce3
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T18324.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE ImpredicativeTypes #-}
+
+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) }
+
+blah x y = return (3::Int)
+
+main = do x <- foo2
+ y <- foo1
+ putStrLn $ show x
+ putStrLn $ show y
diff --git a/testsuite/tests/typecheck/should_run/T18324.stdout b/testsuite/tests/typecheck/should_run/T18324.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..6c72082ed05e8485020f5f3ee280d58c1c372c22
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T18324.stdout
@@ -0,0 +1,2 @@
+(True,3)
+(True,3)
diff --git a/testsuite/tests/typecheck/should_run/T22086.hs b/testsuite/tests/typecheck/should_run/T22086.hs
new file mode 100644
index 0000000000000000000000000000000000000000..4baa9f26a7a7b6cb35aaf1c169e04562114d2589
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T22086.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE ImpredicativeTypes, RebindableSyntax #-}
+
+module Main where
+
+import GHC.Stack (HasCallStack, callStack, prettyCallStack)
+import qualified Prelude as P
+import Prelude hiding ((>>))
+
+
+(>>) :: HasCallStack => String -> String -> String
+_ >> _ = prettyCallStack callStack
+
+x :: String
+x = do
+ "ddd"
+ "fff"
+
+y :: String
+y = "ddd" >> "fff"
+
+main :: IO ()
+main = putStrLn x P.>> putStrLn y
diff --git a/testsuite/tests/typecheck/should_run/T22086.stdout b/testsuite/tests/typecheck/should_run/T22086.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..b0bf6378bf576de33405857819eab24c286a5295
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T22086.stdout
@@ -0,0 +1,4 @@
+CallStack (from HasCallStack):
+ a do statement, called at T22086.hs:15:5 in main:Main
+CallStack (from HasCallStack):
+ >>, called at T22086.hs:19:11 in main:Main
diff --git a/testsuite/tests/typecheck/should_run/Typeable1.stderr b/testsuite/tests/typecheck/should_run/Typeable1.stderr
index 95adaf7b46ea200ac45750e2f521dc68468c56dd..17817ade2617224e70ecfe573b8f8e5f760c0390 100644
--- a/testsuite/tests/typecheck/should_run/Typeable1.stderr
+++ b/testsuite/tests/typecheck/should_run/Typeable1.stderr
@@ -23,9 +23,3 @@ Typeable1.hs:22:5: error: [GHC-40564] [-Winaccessible-code (in -Wdefault), Werro
• Relevant bindings include
y :: TypeRep b2 (bound at Typeable1.hs:19:11)
x :: TypeRep a2 (bound at Typeable1.hs:19:9)
-
-Typeable1.hs:22:5: error: [GHC-94210] [-Woverlapping-patterns (in -Wdefault), Werror=overlapping-patterns]
- Pattern match has inaccessible right hand side
- In a pattern binding in
- a 'do' block:
- App x y <- ...
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index f09be8203c2406fc4d08b626ce7c7d62fe925a73..1d17069549278f775cd174b7155d60a9e73fb6e4 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -171,3 +171,8 @@ test('T21973a', [exit_code(1)], compile_and_run, [''])
test('T21973b', normal, compile_and_run, [''])
test('T23761', normal, compile_and_run, [''])
test('T23761b', normal, compile_and_run, [''])
+
+# Tests for expanding do before typechecking (Impredicative + RebindableSyntax)
+test('T18324', normal, compile_and_run, [''])
+test('T15598', normal, compile_and_run, [''])
+test('T22086', normal, compile_and_run, [''])
diff --git a/utils/haddock b/utils/haddock
index b0b0e0366457c9aefebcc94df74e5de4d00e17b7..2efe3308652bb53efe350cd4768c33c74f359330 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit b0b0e0366457c9aefebcc94df74e5de4d00e17b7
+Subproject commit 2efe3308652bb53efe350cd4768c33c74f359330