summaryrefslogtreecommitdiff
path: root/compiler/GHC/Rename
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2021-02-11 14:44:20 +0000
committerBen Gamari <ben@smart-cactus.org>2021-02-19 11:03:46 -0500
commit4196969c53c55191e644d9eb258c14c2bc8467da (patch)
treebb4608ff96e916c204b6837405690190b70c59db /compiler/GHC/Rename
parentf78f001c91736e31cdfb23959647226f9bd9fe6b (diff)
downloadhaskell-4196969c53c55191e644d9eb258c14c2bc8467da.tar.gz
Improve handling of overloaded labels, literals, lists etcwip/T19154
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. Specifically: * 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 story. 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 (#19293). Metric Decrease: MultiLayerModules T12545
Diffstat (limited to 'compiler/GHC/Rename')
-rw-r--r--compiler/GHC/Rename/Env.hs77
-rw-r--r--compiler/GHC/Rename/Expr.hs379
-rw-r--r--compiler/GHC/Rename/Splice.hs1
3 files changed, 343 insertions, 114 deletions
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 4b5d5d7af3..b1a8ce0351 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -40,8 +40,9 @@ module GHC.Rename.Env (
lookupGreAvailRn,
-- Rebindable Syntax
- lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames,
- lookupIfThenElse, lookupReboundIf,
+ lookupSyntax, lookupSyntaxExpr, lookupSyntaxNames,
+ lookupSyntaxName,
+ lookupIfThenElse,
-- QualifiedDo
lookupQualifiedDoExpr, lookupQualifiedDo,
@@ -67,7 +68,6 @@ import GHC.Types.Name.Reader
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Parser.PostProcess ( setRdrNameSpace )
-import GHC.Builtin.RebindableNames
import GHC.Builtin.Types
import GHC.Types.Name
import GHC.Types.Name.Set
@@ -1950,40 +1950,42 @@ We treat the original (standard) names as free-vars too, because the type checke
checks the type of the user thing against the type of the standard thing.
-}
-lookupIfThenElse :: Bool -- False <=> don't use rebindable syntax under any conditions
- -> RnM (SyntaxExpr GhcRn, FreeVars)
--- Different to lookupSyntax because in the non-rebindable
--- case we desugar directly rather than calling an existing function
--- Hence the (Maybe (SyntaxExpr GhcRn)) return type
-lookupIfThenElse maybe_use_rs
+lookupIfThenElse :: RnM (Maybe Name)
+-- Looks up "ifThenElse" if rebindable syntax is on
+lookupIfThenElse
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
- ; if not (rebindable_on && maybe_use_rs)
- then return (NoSyntaxExprRn, emptyFVs)
+ ; if not rebindable_on
+ then return Nothing
else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
- ; return ( mkRnSyntaxExpr ite
- , unitFV ite ) } }
+ ; return (Just ite) } }
-lookupSyntaxName :: Name -- ^ The standard name
- -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name
+lookupSyntaxName :: Name -- ^ The standard name
+ -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name
+-- Lookup a Name that may be subject to Rebindable Syntax (RS).
+--
+-- - When RS is off, just return the supplied (standard) Name
+--
+-- - When RS is on, look up the OccName of the supplied Name; return
+-- what we find, or the supplied Name if there is nothing in scope
lookupSyntaxName std_name
- = do { rebindable_on <- xoptM LangExt.RebindableSyntax
- ; if not rebindable_on then
- return (std_name, emptyFVs)
- else
- -- Get the similarly named thing from the local environment
- do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))
- ; return (usr_name, unitFV usr_name) } }
+ = do { rebind <- xoptM LangExt.RebindableSyntax
+ ; if not rebind
+ then return (std_name, emptyFVs)
+ else do { nm <- lookupOccRn (mkRdrUnqual (nameOccName std_name))
+ ; return (nm, unitFV nm) } }
lookupSyntaxExpr :: Name -- ^ The standard name
-> RnM (HsExpr GhcRn, FreeVars) -- ^ Possibly a non-standard name
lookupSyntaxExpr std_name
- = fmap (first nl_HsVar) $ lookupSyntaxName std_name
+ = do { (name, fvs) <- lookupSyntaxName std_name
+ ; return (nl_HsVar name, fvs) }
lookupSyntax :: Name -- The standard name
-> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard
-- name
lookupSyntax std_name
- = fmap (first mkSyntaxExpr) $ lookupSyntaxExpr std_name
+ = do { (expr, fvs) <- lookupSyntaxExpr std_name
+ ; return (mkSyntaxExpr expr, fvs) }
lookupSyntaxNames :: [Name] -- Standard names
-> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames
@@ -1996,6 +1998,7 @@ lookupSyntaxNames std_names
do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names
; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } }
+
{-
Note [QualifiedDo]
~~~~~~~~~~~~~~~~~~
@@ -2040,34 +2043,8 @@ lookupQualifiedDoName ctxt std_name
Just modName -> lookupNameWithQualifier std_name modName
--- Lookup a locally-rebound name for Rebindable Syntax (RS).
---
--- - When RS is off, 'lookupRebound' just returns 'Nothing', whatever
--- name it is given.
---
--- - When RS is on, we always try to return a 'Just', and GHC errors out
--- if no suitable name is found in the environment.
---
--- 'Nothing' really is "reserved" and means that rebindable syntax is off.
-lookupRebound :: FastString -> RnM (Maybe (Located Name))
-lookupRebound nameStr = do
- rebind <- xoptM LangExt.RebindableSyntax
- if rebind
- -- If repetitive lookups ever become a problem perormance-wise,
- -- we could lookup all the names we will ever care about just once
- -- at the beginning and stick them in the environment, possibly
- -- populating that "cache" lazily too.
- then (\nm -> Just (L (nameSrcSpan nm) nm)) <$>
- lookupOccRn (mkVarUnqual nameStr)
- else pure Nothing
-
--- | Lookup an @ifThenElse@ binding (see 'lookupRebound').
-lookupReboundIf :: RnM (Maybe (Located Name))
-lookupReboundIf = lookupRebound reboundIfSymbol
-
-- Error messages
-
opDeclErr :: RdrName -> SDoc
opDeclErr n
= hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 3b362d0729..fad921265a 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -49,13 +49,12 @@ import GHC.Builtin.Names
import GHC.Types.FieldLabel
import GHC.Types.Fixity
+import GHC.Types.Id.Make
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.Unique.Set
import GHC.Types.SourceText
-import Data.List (unzip4, minimumBy)
-import Data.Maybe (isJust, isNothing)
import GHC.Utils.Misc
import GHC.Data.List.SetOps ( removeDups )
import GHC.Utils.Error
@@ -67,11 +66,100 @@ import Control.Monad
import GHC.Builtin.Types ( nilDataConName )
import qualified GHC.LanguageExtensions as LangExt
+import Data.List (unzip4, minimumBy)
+import Data.Maybe (isJust, isNothing)
import Control.Arrow (first)
import Data.Ord
import Data.Array
import qualified Data.List.NonEmpty as NE
+{- Note [Handling overloaded and rebindable constructs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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"))
+ 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
+ the user wrote, and 'expanded' is the expanded or desugared version
+ to be typechecked.
+
+* In the TYPECHECKER: typecheck the expansion, in this case
+ fromLabel @"foo"
+ 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.
+
+RebindableSyntax:
+ If RebindableSyntax is off we use the built-in 'fromLabel', defined in
+ GHC.Builtin.Names.fromLabelClassOpName
+ If RebindableSyntax if ON, we look up "fromLabel" in the environment
+ to get whichever one is in scope.
+This is accomplished by lookupSyntaxName, and it applies to all the
+constructs below.
+
+Here are the constructs that we transform in this way. Some are uniform,
+but several have a little bit of special treatment:
+
+* HsIf (if-the-else)
+ if b then e1 else e2 ==> ifThenElse b e1 e2
+ We do this /only/ if rebindable syntax is on, because the coverage
+ checker looks for HsIf (see GHC.HsToCore.Coverage.addTickHsExpr)
+ That means the typechecker and desugarer need to understand HsIf
+ for the non-rebindable-syntax case.
+
+* OverLabel (overloaded labels, #lbl)
+ #lbl ==> fromLabel @"lbl"
+ As ever, we use lookupSyntaxName to look up 'fromLabel'
+ See Note [Overloaded labels]
+
+* ExplicitList (explicit lists [a,b,c])
+ When (and only when) OverloadedLists is on
+ [e1,e2] ==> fromListN 2 [e1,e2]
+ NB: the type checker and desugarer still see ExplicitList,
+ but to them it always means the built-in lists.
+
+* SectionL and SectionR (left and right sections)
+ (`op` e) ==> rightSection op e
+ (e `op`) ==> leftSection (op e)
+ where `leftSection` and `rightSection` are levity-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.
+
+Note [Overloaded labels]
+~~~~~~~~~~~~~~~~~~~~~~~~
+For overloaded labels, note that we /only/ apply `fromLabel` to the
+Symbol argument, so the resulting expression has type
+ fromLabel @"foo" :: forall a. IsLabel "foo" a => a
+Now ordinary Visible Type Application can be used to instantiate the 'a':
+the user may have written (#foo @Int).
+
+Notice that this all works fine in a kind-polymorphic setting (#19154).
+Suppose we have
+ fromLabel :: forall {k1} {k2} (a:k1). blah
+
+Then we want to instantiate those inferred quantifiers k1,k2, before
+type-applying to "foo", so we get
+ fromLabel @Symbol @blah @"foo" ...
+
+And those inferred kind quantifiers will indeed be instantiated when we
+typecheck the renamed-syntax call (fromLabel @"foo").
+-}
+
{-
************************************************************************
* *
@@ -132,7 +220,7 @@ rnExpr (HsVar _ (L l v))
-- OverloadedLists works correctly
-- Note [Empty lists] in GHC.Hs.Expr
, xopt LangExt.OverloadedLists dflags
- -> rnExpr (ExplicitList noExtField Nothing [])
+ -> rnExpr (ExplicitList noExtField [])
| otherwise
-> finishHsVar (L l name) ;
@@ -149,12 +237,15 @@ rnExpr (HsIPVar x v)
rnExpr (HsUnboundVar x v)
= return (HsUnboundVar x v, emptyFVs)
-rnExpr (HsOverLabel x _ v)
- = do { rebindable_on <- xoptM LangExt.RebindableSyntax
- ; if rebindable_on
- then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))
- ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) }
- else return (HsOverLabel x Nothing v, emptyFVs) }
+-- HsOverLabel: see Note [Handling overloaded and rebindable constructs]
+rnExpr (HsOverLabel _ v)
+ = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName
+ ; return ( mkExpandedExpr (HsOverLabel noExtField v) $
+ HsAppType noExtField (genLHsVar from_label) hs_ty_arg
+ , fvs ) }
+ where
+ hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $
+ HsTyLit noExtField (HsStrTy NoSourceText v)
rnExpr (HsLit x lit@(HsString src s))
= do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
@@ -271,16 +362,20 @@ rnExpr (HsDo x do_or_lc (L l stmts))
(\ _ -> return ((), emptyFVs))
; return ( HsDo x do_or_lc (L l stmts'), fvs ) }
-rnExpr (ExplicitList x _ exps)
- = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
- ; (exps', fvs) <- rnExprs exps
- ; if opt_OverloadedLists
- then do {
- ; (from_list_n_name, fvs') <- lookupSyntax fromListNName
- ; return (ExplicitList x (Just from_list_n_name) exps'
- , fvs `plusFV` fvs') }
- else
- return (ExplicitList x Nothing exps', fvs) }
+-- ExplicitList: see Note [Handling overloaded and rebindable constructs]
+rnExpr (ExplicitList x exps)
+ = do { (exps', fvs) <- rnExprs exps
+ ; opt_OverloadedLists <- xoptM LangExt.OverloadedLists
+ ; if not opt_OverloadedLists
+ then return (ExplicitList x exps', fvs)
+ else
+ do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
+ ; let rn_list = ExplicitList x exps'
+ lit_n = mkIntegralLit (length exps)
+ hs_lit = wrapGenSpan (HsLit noExtField (HsInt noExtField lit_n))
+ exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list]
+ ; return ( mkExpandedExpr rn_list exp_list
+ , fvs `plusFV` fvs') } }
rnExpr (ExplicitTuple x tup_args boxity)
= do { checkTupleSection tup_args
@@ -322,24 +417,31 @@ rnExpr (ExprWithTySig _ expr pty)
; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
rnLExpr expr
; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }
+
+-- 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
+ = do { (p', fvP) <- rnLExpr p
; (b1', fvB1) <- rnLExpr b1
; (b2', fvB2) <- rnLExpr b2
- ; mifteName <- lookupReboundIf
- ; let subFVs = plusFVs [fvP, fvB1, fvB2]
- ; return $ case mifteName of
- -- RS is off, we keep an 'HsIf' node around
- Nothing ->
- (HsIf noExtField p' b1' b2', subFVs)
- -- See Note [Rebindable syntax and HsExpansion].
- Just ifteName ->
- let ifteExpr = rebindIf ifteName p' b1' b2'
- in (ifteExpr, plusFVs [unitFV (unLoc ifteName), subFVs])
- }
+ ; 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 (HsMultiIf x alts)
= do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
- -- ; return (HsMultiIf ty alts', fvs) }
; return (HsMultiIf x alts', fvs) }
rnExpr (ArithSeq x _ seq)
@@ -388,13 +490,11 @@ rnExpr e@(HsStatic _ expr) = do
let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr
return (HsStatic fvExpr' expr', fvExpr)
-{-
-************************************************************************
+{- *********************************************************************
* *
Arrow notation
* *
-************************************************************************
--}
+********************************************************************* -}
rnExpr (HsProc x pat body)
= newArrowScope $
@@ -405,23 +505,160 @@ rnExpr (HsProc x pat body)
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
-- HsWrap
-----------------------
--- See Note [Parsing sections] in GHC.Parser
+
+{- *********************************************************************
+* *
+ Operator sections
+* *
+********************************************************************* -}
+
+
rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+-- See Note [Parsing sections] in GHC.Parser
+-- Also see Note [Handling overloaded and rebindable constructs]
+
rnSection section@(SectionR x op expr)
+ -- See Note [Left and right sections]
= do { (op', fvs_op) <- rnLExpr op
; (expr', fvs_expr) <- rnLExpr expr
; checkSectionPrec InfixR section op' expr'
- ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) }
+ ; let rn_section = SectionR x op' expr'
+ ds_section = genHsApps rightSectionName [op',expr']
+ ; return ( mkExpandedExpr rn_section ds_section
+ , fvs_op `plusFV` fvs_expr) }
rnSection section@(SectionL x expr op)
+ -- See Note [Left and right sections]
= do { (expr', fvs_expr) <- rnLExpr expr
; (op', fvs_op) <- rnLExpr op
; checkSectionPrec InfixL section op' expr'
- ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) }
+ ; postfix_ops <- xoptM LangExt.PostfixOperators
+ -- Note [Left and right sections]
+ ; let rn_section = SectionL x expr' op'
+ ds_section
+ | postfix_ops = HsApp noExtField op' expr'
+ | otherwise = genHsApps leftSectionName
+ [wrapGenSpan $ HsApp noExtField op' expr']
+ ; return ( mkExpandedExpr rn_section ds_section
+ , fvs_op `plusFV` fvs_expr) }
rnSection other = pprPanic "rnSection" (ppr other)
+{- Note [Left and right sections]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Dealing with left sections (x *) and right sections (* x) is
+surprisingly fiddly. We expand like this
+ (`op` e) ==> rightSection op e
+ (e `op`) ==> leftSection (op e)
+
+Using an auxiliary function in this way avoids the awkwardness of
+generating a lambda, esp if `e` is a redex, so we *don't* want
+to generate `(\x -> op x e)`. See Historical
+Note [Desugaring operator sections]
+
+Here are their definitions:
+ leftSection :: forall r1 r2 n (a:TYPE r1) (b:TYPE r2).
+ (a %n-> b) -> a %n-> b
+ leftSection f x = f x
+
+ rightSection :: forall r1 r2 r3 (a:TYPE r1) (b:TYPE r2) (c:TYPE r3).
+ (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c
+ rightSection f y x = f x y
+
+Note the wrinkles:
+
+* We do /not/ use lookupSyntaxName, which would make left and right
+ section fall under RebindableSyntax. Reason: it would be a user-
+ facing change, and there are some tricky design choices (#19354).
+ Plus, infix operator applications would be trickier to make
+ rebindable, so it'd be inconsistent to do so for sections.
+
+ TL;DR: we still us the renamer-expansion mechanism for operator
+ sections , but only to eliminate special-purpose code paths in the
+ renamer and desugarer.
+
+* leftSection and rightSection must be levity-polymorphic, to allow
+ (+# 4#) and (4# +#) to work. See GHC.Types.Id.Make.
+ Note [Wired-in Ids for rebindable syntax] in
+
+* leftSection and rightSection must be multiplicity-polymorphic.
+ (Test linear/should_compile/OldList showed this up.)
+
+* Because they are levity-polymorphic, we have to define them
+ as wired-in Ids, with compulsory inlining. See
+ GHC.Types.Id.Make.leftSectionId, rightSectionId.
+
+* leftSection is just ($) really; but unlike ($) it is
+ levity polymorphic in the result type, so we can write
+ `(x +#)`, say.
+
+* The type of leftSection must have an arrow in its first argument,
+ because (x `ord`) should be rejected, because ord does not take two
+ arguments
+
+* It's important that we define leftSection in an eta-expanded way,
+ (i.e. not leftSection f = f), so that
+ (True `undefined`) `seq` ()
+ = (leftSection (undefined True) `seq` ())
+ evaluates to () and not undefined
+
+* If PostfixOperators is ON, then we expand a left section like this:
+ (e `op`) ==> op e
+ with no auxiliary function at all. Simple!
+
+
+Historical Note [Desugaring operator sections]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This Note explains some historical trickiness in desugaring left and
+right sections. That trickiness has completely disappeared now that
+we desugar to calls to 'leftSection` and `rightSection`, but I'm
+leaving it here to remind us how nice the new story is.
+
+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.
+-}
+
+
{-
************************************************************************
* *
@@ -513,8 +750,13 @@ rnCmd (HsCmdIf x _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
; (b1', fvB1) <- rnLCmd b1
; (b2', fvB2) <- rnLCmd b2
- ; (mb_ite, fvITE) <- lookupIfThenElse True
- ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
+
+ ; mb_ite <- lookupIfThenElse
+ ; let (ite, fvITE) = case mb_ite of
+ Just ite_name -> (mkRnSyntaxExpr ite_name, unitFV ite_name)
+ Nothing -> (NoSyntaxExprRn, emptyFVs)
+
+ ; return (HsCmdIf x ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
rnCmd (HsCmdLet x (L l binds) cmd)
= rnLocalBindsAndThen binds $ \ binds' _ -> do
@@ -2235,25 +2477,36 @@ getMonadFailOp ctxt
return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
| otherwise = lookupQualifiedDo ctxt failMName
--- Rebinding 'if's to 'ifThenElse' applications.
---
+
+{- *********************************************************************
+* *
+ Generating code for HsExpanded
+ See Note [Handling overloaded and rebindable constructs]
+* *
+********************************************************************* -}
+
+genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
+genHsApps fun args = foldl genHsApp (genHsVar fun) args
+
+genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
+genHsApp fun arg = HsApp noExtField (wrapGenSpan fun) arg
+
+genLHsVar :: Name -> LHsExpr GhcRn
+genLHsVar nm = wrapGenSpan $ genHsVar nm
+
+genHsVar :: Name -> HsExpr GhcRn
+genHsVar nm = HsVar noExtField $ wrapGenSpan nm
+
+wrapGenSpan :: a -> Located a
+-- Wrap something in a "generatedSrcSpan"
-- See Note [Rebindable syntax and HsExpansion]
-rebindIf
- :: Located Name -- 'Name' for the 'ifThenElse' function we will rebind to
- -> LHsExpr GhcRn -- renamed condition
- -> LHsExpr GhcRn -- renamed true branch
- -> LHsExpr GhcRn -- renamed false branch
- -> HsExpr GhcRn -- rebound if expression
-rebindIf ifteName p b1 b2 =
- let ifteOrig = HsIf noExtField p b1 b2
- ifteFun = L generatedSrcSpan (HsVar noExtField ifteName)
- -- ifThenElse var
- ifteApp = mkHsAppsWith (\_ _ e -> L generatedSrcSpan e)
- ifteFun
- [p, b1, b2]
- -- desugared_if_expr =
- -- ifThenElse desugared_predicate
- -- desugared_true_branch
- -- desugared_false_branch
- in mkExpanded XExpr ifteOrig (unLoc ifteApp)
- -- (source_if_expr, desugared_if_expr)
+wrapGenSpan x = L generatedSrcSpan x
+
+-- | 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)
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index b0e6bb1159..30698d0f98 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -496,7 +496,6 @@ to try and
{- Note [Rebindable syntax and Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
When processing Template Haskell quotes with Rebindable Syntax (RS) enabled,
there are two possibilities: apply the RS rules to the quotes or don't.