Commit 4196969c authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Ben Gamari

Improve handling of overloaded labels, literals, lists etc

When implementing Quick Look I'd failed to remember that overloaded
labels, like #foo, should be treated as a "head", so that they can be
instantiated with Visible Type Application. This caused #19154.

A very similar ticket covers overloaded literals: #19167.

This patch fixes both problems, but (annoyingly, albeit temporarily)
in two different ways.

Overloaded labels

I dealt with overloaded labels by buying fully into the
Rebindable Syntax approach described in GHC.Hs.Expr
Note [Rebindable syntax and HsExpansion].

There is a good overview in GHC.Rename.Expr
Note [Handling overloaded and rebindable constructs].
That module contains much of the payload for this patch.


* Overloaded labels are expanded in the renamer, fixing #19154.
  See Note [Overloaded labels] in GHC.Rename.Expr.

* Left and right sections used to have special code paths in the
  typechecker and desugarer.  Now we just expand them in the
  renamer. This is harder than it sounds.  See GHC.Rename.Expr
  Note [Left and right sections].

* Infix operator applications are expanded in the typechecker,
  specifically in GHC.Tc.Gen.App.splitHsApps.  See
  Note [Desugar OpApp in the typechecker] in that module

* ExplicitLists are expanded in the renamer, when (and only when)
  OverloadedLists is on.

* HsIf is expanded in the renamer when (and only when) RebindableSyntax
  is on.  Reason: the coverage checker treats HsIf specially.  Maybe
  we could instead expand it unconditionally, and fix up the coverage
  checker, but I did not attempt that.

Overloaded literals

Overloaded literals, like numbers (3, 4.2) and strings with
OverloadedStrings, were not working correctly with explicit type
applications (see #19167).  Ideally I'd also expand them in the
renamer, like the stuff above, but I drew back on that because they
can occur in HsPat as well, and I did not want to to do the HsExpanded
thing for patterns.

But they *can* now be the "head" of an application in the typechecker,
and hence something like ("foo" @T) works now.  See
GHC.Tc.Gen.Head.tcInferOverLit.  It's also done a bit more elegantly,
rather than by constructing a new HsExpr and re-invoking the
typechecker. There is some refactoring around tcShortCutLit.

Ultimately there is more to do here, following the Rebindable Syntax

There are a lot of knock-on effects:

* HsOverLabel and ExplicitList no longer need funny (Maybe SyntaxExpr)
  fields to support rebindable syntax -- good!

* HsOverLabel, OpApp, SectionL, SectionR all become impossible in the
  output of the typecheker, GhcTc; so we set their extension fields to
  Void. See GHC.Hs.Expr Note [Constructor cannot occur]

* Template Haskell quotes for HsExpanded is a bit tricky.  See
  Note [Quotation and rebindable syntax] in GHC.HsToCore.Quote.

* In GHC.HsToCore.Match.viewLExprEq, which groups equal HsExprs for the
  purpose of pattern-match overlap checking, I found that dictionary
  evidence for the same type could have two different names.  Easily
  fixed by comparing types not names.

* I did quite a bit of annoying fiddling around in GHC.Tc.Gen.Head and
  GHC.Tc.Gen.App to get error message locations and contexts right,
  esp in splitHsApps, and the HsExprArg type.  Tiresome and not very
  illuminating.  But at least the tricky, higher order, Rebuilder
  function is gone.

* Some refactoring in GHC.Tc.Utils.Monad around contexts and locations
  for rebindable syntax.

* Incidentally fixes #19346, because we now print renamed, rather than
  typechecked, syntax in error mesages about applications.

The commit removes the vestigial module GHC.Builtin.RebindableNames,
and thus triggers a 2.4% metric decrease for test MultiLayerModules

Metric Decrease:
parent f78f001c
Pipeline #31805 failed with stages
in 463 minutes and 15 seconds
......@@ -443,7 +443,7 @@ basicKnownKeyNames
knownNatClassName, knownSymbolClassName, knownCharClassName,
-- Overloaded labels
-- Implicit Parameters
......@@ -1626,9 +1626,9 @@ knownCharClassName :: Name
knownCharClassName = clsQual gHC_TYPELITS (fsLit "KnownChar") knownCharClassNameKey
-- Overloaded labels
isLabelClassName :: Name
= clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey
fromLabelClassOpName :: Name
= varQual gHC_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey
-- Implicit Parameters
ipClassName :: Name
......@@ -1786,9 +1786,6 @@ knownCharClassNameKey = mkPreludeClassUnique 44
ghciIoClassKey :: Unique
ghciIoClassKey = mkPreludeClassUnique 45
isLabelClassNameKey :: Unique
isLabelClassNameKey = mkPreludeClassUnique 46
semigroupClassKey, monoidClassKey :: Unique
semigroupClassKey = mkPreludeClassUnique 47
monoidClassKey = mkPreludeClassUnique 48
......@@ -2332,6 +2329,9 @@ sndIdKey = mkPreludeMiscIdUnique 42
otherwiseIdKey = mkPreludeMiscIdUnique 43
assertIdKey = mkPreludeMiscIdUnique 44
leftSectionKey, rightSectionKey :: Unique
leftSectionKey = mkPreludeMiscIdUnique 45
rightSectionKey = mkPreludeMiscIdUnique 46
rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 101
......@@ -2413,6 +2413,10 @@ mfixIdKey = mkPreludeMiscIdUnique 175
failMClassOpKey :: Unique
failMClassOpKey = mkPreludeMiscIdUnique 176
-- fromLabel
fromLabelClassOpKey :: Unique
fromLabelClassOpKey = mkPreludeMiscIdUnique 177
-- Arrow notation
arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey,
loopAIdKey :: Unique
module GHC.Builtin.RebindableNames where
import GHC.Data.FastString
reboundIfSymbol :: FastString
reboundIfSymbol = fsLit "ifThenElse"
......@@ -23,10 +23,13 @@ module GHC.Builtin.Types.Prim(
alphaTys, alphaTy, betaTy, gammaTy, deltaTy,
alphaTyVarsUnliftedRep, alphaTyVarUnliftedRep,
alphaTysUnliftedRep, alphaTyUnliftedRep,
runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty,
openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar,
runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar,
runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty,
openAlphaTyVar, openBetaTyVar, openGammaTyVar,
openAlphaTy, openBetaTy, openGammaTy,
multiplicityTyVar1, multiplicityTyVar2,
-- Kind constructors...
tYPETyCon, tYPETyConName,
......@@ -375,26 +378,31 @@ alphaTysUnliftedRep = mkTyVarTys alphaTyVarsUnliftedRep
alphaTyUnliftedRep :: Type
(alphaTyUnliftedRep:_) = alphaTysUnliftedRep
runtimeRep1TyVar, runtimeRep2TyVar :: TyVar
(runtimeRep1TyVar : runtimeRep2TyVar : _)
runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar :: TyVar
(runtimeRep1TyVar : runtimeRep2TyVar : runtimeRep3TyVar : _)
= drop 16 (mkTemplateTyVars (repeat runtimeRepTy)) -- selects 'q','r'
runtimeRep1Ty, runtimeRep2Ty :: Type
runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: Type
runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar
runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar
runtimeRep3Ty = mkTyVarTy runtimeRep3TyVar
openAlphaTyVar, openBetaTyVar :: TyVar
openAlphaTyVar, openBetaTyVar, openGammaTyVar :: TyVar
-- alpha :: TYPE r1
-- beta :: TYPE r2
= mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty]
-- gamma :: TYPE r3
= mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty, tYPE runtimeRep3Ty]
openAlphaTy, openBetaTy :: Type
openAlphaTy, openBetaTy, openGammaTy :: Type
openAlphaTy = mkTyVarTy openAlphaTyVar
openBetaTy = mkTyVarTy openBetaTyVar
openGammaTy = mkTyVarTy openGammaTyVar
multiplicityTyVar1, multiplicityTyVar2 :: TyVar
(multiplicityTyVar1 : multiplicityTyVar2 : _)
= drop 13 (mkTemplateTyVars (repeat multiplicityTy)) -- selects 'n', 'm'
multiplicityTyVar :: TyVar
multiplicityTyVar = mkTemplateTyVars (repeat multiplicityTy) !! 13 -- selects 'n'
......@@ -432,7 +440,7 @@ funTyCon :: TyCon
funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm
-- See also unrestrictedFunTyCon
tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar
tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar1
, mkNamedTyConBinder Inferred runtimeRep1TyVar
, mkNamedTyConBinder Inferred runtimeRep2TyVar ]
++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty
......@@ -66,14 +66,13 @@ import Data.Data hiding (Fixity(..))
import qualified Data.Data as Data (Fixity(..))
import qualified Data.Kind
import Data.Maybe (isJust)
import Data.Void ( Void )
{- *********************************************************************
* *
\subsection{Expressions proper}
Expressions proper
* *
********************************************************************* -}
-- | Post-Type checking Expression
......@@ -191,10 +190,21 @@ type instance PendingTcSplice' (GhcPass _) = PendingTcSplice
-- ---------------------------------------------------------------------
{- Note [Constructor cannot occur]
Some data constructors can't occur in certain phases; e.g. the output
of the type checker never has OverLabel. We signal this by setting
the extension field to Void. For example:
type instance XOverLabel GhcTc = Void
dsExpr (HsOverLabel x _) = absurd x
It would be better to omit the pattern match altogether, but we
could only do that if the extension field was strict (#18764)
type instance XVar (GhcPass _) = NoExtField
type instance XConLikeOut (GhcPass _) = NoExtField
type instance XRecFld (GhcPass _) = NoExtField
type instance XOverLabel (GhcPass _) = NoExtField
type instance XIPVar (GhcPass _) = NoExtField
type instance XOverLitE (GhcPass _) = NoExtField
type instance XLitE (GhcPass _) = NoExtField
......@@ -202,6 +212,12 @@ type instance XLam (GhcPass _) = NoExtField
type instance XLamCase (GhcPass _) = NoExtField
type instance XApp (GhcPass _) = NoExtField
-- OverLabel not present in GhcTc pass; see GHC.Rename.Expr
-- Note [Handling overloaded and rebindable constructs]
type instance XOverLabel GhcPs = NoExtField
type instance XOverLabel GhcRn = NoExtField
type instance XOverLabel GhcTc = Void -- See Note [Constructor cannot occur]
type instance XUnboundVar GhcPs = NoExtField
type instance XUnboundVar GhcRn = NoExtField
type instance XUnboundVar GhcTc = HoleExprRef
......@@ -214,14 +230,24 @@ type instance XAppTypeE GhcPs = NoExtField
type instance XAppTypeE GhcRn = NoExtField
type instance XAppTypeE GhcTc = Type
-- OpApp not present in GhcTc pass; see GHC.Rename.Expr
-- Note [Handling overloaded and rebindable constructs]
type instance XOpApp GhcPs = NoExtField
type instance XOpApp GhcRn = Fixity
type instance XOpApp GhcTc = Fixity
type instance XOpApp GhcTc = Void -- See Note [Constructor cannot occur]
-- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr
-- Note [Handling overloaded and rebindable constructs]
type instance XSectionL GhcPs = NoExtField
type instance XSectionR GhcPs = NoExtField
type instance XSectionL GhcRn = NoExtField
type instance XSectionR GhcRn = NoExtField
type instance XSectionL GhcTc = Void -- See Note [Constructor cannot occur]
type instance XSectionR GhcTc = Void -- See Note [Constructor cannot occur]
type instance XNegApp (GhcPass _) = NoExtField
type instance XPar (GhcPass _) = NoExtField
type instance XSectionL (GhcPass _) = NoExtField
type instance XSectionR (GhcPass _) = NoExtField
type instance XExplicitTuple (GhcPass _) = NoExtField
type instance XExplicitSum GhcPs = NoExtField
......@@ -245,6 +271,13 @@ type instance XDo GhcTc = Type
type instance XExplicitList GhcPs = NoExtField
type instance XExplicitList GhcRn = NoExtField
type instance XExplicitList GhcTc = Type
-- GhcPs: ExplicitList includes all source-level
-- list literals, including overloaded ones
-- GhcRn and GhcTc: ExplicitList used only for list literals
-- that denote Haskell's built-in lists. Overloaded lists
-- have been expanded away in the renamer
-- See Note [Handling overloaded and rebindable constructs]
-- in GHC.Rename.Expr
type instance XRecordCon GhcPs = NoExtField
type instance XRecordCon GhcRn = NoExtField
......@@ -288,8 +321,6 @@ data XXExprGhcTc
= WrapExpr {-# UNPACK #-} !(HsWrap HsExpr)
| ExpansionExpr {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))
-- ---------------------------------------------------------------------
type instance XSCC (GhcPass _) = NoExtField
......@@ -346,7 +377,7 @@ ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv
ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c
ppr_expr (HsRecFld _ f) = pprPrefixOcc f
ppr_expr (HsIPVar _ v) = ppr v
ppr_expr (HsOverLabel _ _ l) = char '#' <> ppr l
ppr_expr (HsOverLabel _ l) = char '#' <> ppr l
ppr_expr (HsLit _ lit) = ppr lit
ppr_expr (HsOverLit _ lit) = ppr lit
ppr_expr (HsPar _ e) = parens (ppr_lexpr e)
......@@ -465,7 +496,7 @@ ppr_expr (HsLet _ (L _ binds) expr)
ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ _ exprs)
ppr_expr (ExplicitList _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds })
......@@ -677,6 +708,139 @@ instance Outputable (HsPragE (GhcPass p)) where
-- without quotes.
<+> pprWithSourceText stl (ftext lbl) <+> text "#-}"
{- *********************************************************************
* *
HsExpansion and rebindable syntax
* *
********************************************************************* -}
{- Note [Rebindable syntax and HsExpansion]
We implement rebindable syntax (RS) support by performing a desugaring
in the renamer. We transform GhcPs expressions affected by RS into the
appropriate desugared form, but **annotated with the original expression**.
Let us consider a piece of code like:
{-# LANGUAGE RebindableSyntax #-}
ifThenElse :: Char -> () -> () -> ()
ifThenElse _ _ _ = ()
x = if 'a' then () else True
The parsed AST for the RHS of x would look something like (slightly simplified):
L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True))
Upon seeing such an AST with RS on, we could transform it into a
mere function call, as per the RS rules, equivalent to the
following function application:
ifThenElse 'a' () True
which doesn't typecheck. But GHC would report an error about
not being able to match the third argument's type (Bool) with the
expected type: (), in the expression _as desugared_, i.e in
the aforementioned function application. But the user never
wrote a function application! This would be pretty bad.
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
expression in its first field, and the desugared one in the
second field. The resulting renamed AST would look like:
L locif (XExpr
(HsIf (L loca 'a')
(L loctrue ())
(L locfalse True)
(App (L generatedSrcSpan
(App (L generatedSrcSpan
(App (L generatedSrcSpan (Var ifThenElse))
(L loca 'a')
(L loctrue ())
(L locfalse True)
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)'
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
SyntaxExpr-based, typechecking/desugaring-to-core time
implementation of rebindable syntax. The key idea is to decorate
some elements of the desugared expression so as to be able to
give them a special treatment when typechecking the desugared
expression, to print a different context line or skip one
Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in
TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we
entered generated code, i.e code fabricated by the compiler when rebinding some
syntax. If someone tries to push some error context line while that field is set
to True, the pushing won't actually happen and the context line is just dropped.
Once we 'setSrcSpan' a real span (for an expression that was in the original
source code), we set 'tcl_in_gen_code' back to False, indicating that we
"emerged from the generated code tunnel", and that the expressions we will be
processing are relevant to report in context lines again.
You might wonder why TcLclEnv has both
tcl_loc :: RealSrcSpan
tcl_in_gen_code :: Bool
Could we not store a Maybe RealSrcSpan? The problem is that we still
generate constraints when processing generated code, and a CtLoc must
contain a RealSrcSpan -- otherwise, error messages might appear
without source locations. So tcl_loc keeps the RealSrcSpan of the last
location spotted that wasn't generated; it's as good as we're going to
get in generated code. Once we get to sub-trees that are not
generated, then we update the RealSrcSpan appropriately, and set the
tcl_in_gen_code Bool to False.
A general recipe to follow this approach for new constructs could go as follows:
- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your
construct, in HsExpr or related syntax data types.
- At renaming-time:
- take your original node of interest (HsIf above)
- rename its subexpressions (condition, true branch, false branch above)
- construct the suitable "rebound"-and-renamed result (ifThenElse call
above), where the 'SrcSpan' attached to any _fabricated node_ (the
HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'
- take both the original node and that rebound-and-renamed result and wrap
them in an XExpr: XExpr (HsExpanded <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
typecheck the desugared expression while reporting the original one in
-- See Note [Rebindable syntax and HsExpansion] just above.
data HsExpansion a b
= HsExpanded a b
deriving Data
-- | Just print the original expression (the @a@).
instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
ppr (HsExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)
* *
......@@ -545,7 +545,7 @@ nlHsIf cond true false = noLoc (HsIf noExtField cond true false)
nlHsCase expr matches
= noLoc (HsCase noExtField expr (mkMatchGroup Generated matches))
nlList exprs = noLoc (ExplicitList noExtField Nothing exprs)
nlList exprs = noLoc (ExplicitList noExtField exprs)
nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p)
......@@ -478,19 +478,18 @@ addTickLHsExprNever (L pos e0) = do
e1 <- addTickHsExpr e0
return $ L pos e1
-- general heuristic: expressions which do not denote values are good
-- break points
-- General heuristic: expressions which are calls (do not denote
-- values) are good break points.
isGoodBreakExpr :: HsExpr GhcTc -> Bool
isGoodBreakExpr (HsApp {}) = True
isGoodBreakExpr (HsAppType {}) = True
isGoodBreakExpr (OpApp {}) = True
isGoodBreakExpr _other = False
isGoodBreakExpr e = isCallSite e
isCallSite :: HsExpr GhcTc -> Bool
isCallSite HsApp{} = True
isCallSite HsAppType{} = True
isCallSite OpApp{} = True
isCallSite _ = False
isCallSite (XExpr (ExpansionExpr (HsExpanded _ 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)
......@@ -533,7 +532,6 @@ addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)
addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)
(addTickLHsExprNever e)
(return ty)
addTickHsExpr (OpApp fix e1 e2 e3) =
liftM4 OpApp
(return fix)
......@@ -587,15 +585,8 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts))
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
_ -> Nothing
addTickHsExpr (ExplicitList ty wit es) =
liftM3 ExplicitList
(return ty)
(addTickWit wit)
(mapM (addTickLHsExpr) es)
where addTickWit Nothing = return Nothing
addTickWit (Just fln)
= do fln' <- addTickSyntaxExpr hpcSrcSpan fln
return (Just fln')
addTickHsExpr (ExplicitList ty es)
= liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es)
addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
......@@ -70,8 +70,7 @@ import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Core.PatSyn
import Control.Monad
import qualified GHC.LanguageExtensions as LangExt
import Data.Void( absurd )
......@@ -276,7 +275,6 @@ dsExpr (ExprWithTySig _ e _) = dsLExpr e
dsExpr (HsConLikeOut _ con) = dsConLike con
dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar"
dsExpr (HsOverLabel{}) = panic "dsExpr: HsOverLabel"
dsExpr (HsLit _ lit)
= do { warnAboutOverflowedLit lit
......@@ -285,7 +283,10 @@ dsExpr (HsLit _ lit)
dsExpr (HsOverLit _ lit)
= do { warnAboutOverflowedOverLit lit
; dsOverLit lit }
dsExpr (XExpr (ExpansionExpr (HsExpanded _ b))) = dsExpr b
dsExpr (XExpr (ExpansionExpr (HsExpanded _ b)))
= dsExpr b
dsExpr hswrap@(XExpr (WrapExpr (HsWrap co_fn e)))
= do { e' <- case e of
HsVar _ (L _ var) -> return $ varToCoreExpr var
......@@ -349,102 +350,8 @@ Then we get
That 'g' in the 'in' part is an evidence variable, and when
converting to core it must become a CO.
Note [Desugaring operator sections]
Desugaring left sections with -XPostfixOperators is straightforward: convert
(expr `op`) to (op expr).
Without -XPostfixOperators it's a bit more tricky. At first it looks as if we
can convert
(expr `op`)
naively to
\x -> op expr x
But no! expr might be a redex, and we can lose laziness badly this
way. Consider
map (expr `op`) xs
for example. If expr were a redex then eta-expanding naively would
result in multiple evaluations where the user might only have expected one.
So we convert instead to
let y = expr in \x -> op y x
Also, note that we must do this for both right and (perhaps surprisingly) left
sections. Why are left sections necessary? Consider the program (found in #18151),
seq (True `undefined`) ()
according to the Haskell Report this should reduce to () (as it specifies
desugaring via eta expansion). However, if we fail to eta expand we will rather
bottom. Consequently, we must eta expand even in the case of a left section.
If `expr` is actually just a variable, say, then the simplifier
will inline `y`, eliminating the redundant `let`.
Note that this works even in the case that `expr` is unlifted. In this case
bindNonRec will automatically do the right thing, giving us:
case expr of y -> (\x -> op y x)
See #18151.
dsExpr e@(OpApp _ e1 op e2)
= -- for the type of y, we need the type of op's 2nd argument
do { op' <- dsLExpr op
; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
(\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
-- dsExpr (SectionL op expr) === (expr `op`) ~> \y -> op expr y
-- See Note [Desugaring operator sections].
-- N.B. this also must handle postfix operator sections due to -XPostfixOperators.
dsExpr e@(SectionL _ expr op) = do
postfix_operators <- xoptM LangExt.PostfixOperators
if postfix_operators then
-- Desugar (e !) to ((!) e)
do { op' <- dsLExpr op
; dsWhenNoErrs (dsLExprNoLP expr) $ \expr' ->
mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr' }
else do
core_op <- dsLExpr op
x_core <- dsLExpr expr
case splitFunTys (exprType core_op) of
-- Binary operator section
(x_ty:y_ty:_, _) ->
(newSysLocalsDsNoLP [x_ty, y_ty])
(\[x_id, y_id] ->
bindNonRec x_id x_core
$ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e)
core_op [Var x_id, Var y_id]))
-- Postfix operator section
(_:_, _) ->
return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core
_ -> pprPanic "dsExpr(SectionL)" (ppr e)
-- dsExpr (SectionR op expr) === (`op` expr) ~> \x -> op x expr
-- See Note [Desugaring operator sections].
dsExpr e@(SectionR _ op expr) = do
core_op <- dsLExpr op
let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
y_core <- dsLExpr expr
dsWhenNoErrs (newSysLocalsDsNoLP [x_ty, y_ty])
(\[x_id, y_id] -> bindNonRec y_id y_core $
Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
core_op [Var x_id, Var y_id]))
dsExpr (ExplicitTuple _ tup_args boxity)
= do { let go (lam_vars, args) (L _ (Missing (Scaled mult ty)))
-- For every missing expression, we need
......@@ -516,8 +423,7 @@ dsExpr (HsMultiIf res_ty alts)
dsExpr (ExplicitList elt_ty wit xs)
= dsExplicitList elt_ty wit xs
dsExpr (ExplicitList elt_ty xs) = dsExplicitList elt_ty xs
dsExpr (ArithSeq expr witness seq)
= case witness of
......@@ -878,9 +784,18 @@ dsExpr (HsBinTick _ ixT ixF e) = do
mkBinaryTickBox ixT ixF e2