diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2021-02-11 14:44:20 +0000 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2021-02-19 11:03:46 -0500 |
| commit | 4196969c53c55191e644d9eb258c14c2bc8467da (patch) | |
| tree | bb4608ff96e916c204b6837405690190b70c59db | |
| parent | f78f001c91736e31cdfb23959647226f9bd9fe6b (diff) | |
| download | haskell-wip/T19154.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
59 files changed, 1449 insertions, 1027 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 0764e5c536..fc0589730a 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -443,7 +443,7 @@ basicKnownKeyNames knownNatClassName, knownSymbolClassName, knownCharClassName, -- Overloaded labels - isLabelClassName, + fromLabelClassOpName, -- Implicit Parameters ipClassName, @@ -1626,9 +1626,9 @@ knownCharClassName :: Name knownCharClassName = clsQual gHC_TYPELITS (fsLit "KnownChar") knownCharClassNameKey -- Overloaded labels -isLabelClassName :: Name -isLabelClassName - = clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey +fromLabelClassOpName :: Name +fromLabelClassOpName + = 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 diff --git a/compiler/GHC/Builtin/RebindableNames.hs b/compiler/GHC/Builtin/RebindableNames.hs deleted file mode 100644 index 0a07224b15..0000000000 --- a/compiler/GHC/Builtin/RebindableNames.hs +++ /dev/null @@ -1,6 +0,0 @@ -module GHC.Builtin.RebindableNames where - -import GHC.Data.FastString - -reboundIfSymbol :: FastString -reboundIfSymbol = fsLit "ifThenElse" diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index 89093a2350..27df5236a3 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -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, - multiplicityTyVar, + 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 -[openAlphaTyVar,openBetaTyVar] - = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty] +-- gamma :: TYPE r3 +[openAlphaTyVar,openBetaTyVar,openGammaTyVar] + = 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 where -- See also unrestrictedFunTyCon - tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar + tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar1 , mkNamedTyConBinder Inferred runtimeRep1TyVar , mkNamedTyConBinder Inferred runtimeRep2TyVar ] ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 489c172e23..ab6ebadd06 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -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 + (HsExpanded + (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 +altogether. + +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 + errors + +-} + +-- 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) + + {- ************************************************************************ * * diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index e90f0a9c0f..2745a5944e 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -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) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 8d95675efe..df7d00071b 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -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 diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index d2c5d77cbe..50d9594e3c 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -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:_, _) -> - dsWhenNoErrs - (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 } + +-- HsSyn constructs that just shouldn't be here, because +-- the renamer removed them. See GHC.Rename.Expr. +-- Note [Handling overloaded and rebindable constructs] +dsExpr (HsOverLabel x _) = absurd x +dsExpr (OpApp x _ _ _) = absurd x +dsExpr (SectionL x _ _) = absurd x +dsExpr (SectionR x _ _) = absurd x + -- HsSyn constructs that just shouldn't be here: -dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" -dsExpr (HsDo {}) = panic "dsExpr:HsDo" +dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" +dsExpr (HsDo {}) = panic "dsExpr:HsDo" ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr ds_prag_expr (HsPragSCC _ _ cc) expr = do @@ -976,10 +891,10 @@ time. maxBuildLength :: Int maxBuildLength = 32 -dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] +dsExplicitList :: Type -> [LHsExpr GhcTc] -> DsM CoreExpr -- See Note [Desugaring explicit lists] -dsExplicitList elt_ty Nothing xs +dsExplicitList elt_ty xs = do { dflags <- getDynFlags ; xs' <- mapM dsLExprNoLP xs ; if xs' `lengthExceeds` maxBuildLength @@ -995,12 +910,6 @@ dsExplicitList elt_ty Nothing xs mk_build_list xs' (cons, _) (nil, _) = return (foldr (App . App (Var cons)) (Var nil) xs') -dsExplicitList elt_ty (Just fln) xs - = do { list <- dsExplicitList elt_ty Nothing xs - ; dflags <- getDynFlags - ; let platform = targetPlatform dflags - ; dsSyntaxExpr fln [mkIntExprInt platform (length xs), list] } - dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr dsArithSeq expr (From from) = App <$> dsExpr expr <*> dsLExprNoLP from diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 86095b8e3f..8576197d4d 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -1063,7 +1063,6 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- the instance for IPName derives using the id, so this works if the -- above does exp (HsIPVar _ i) (HsIPVar _ i') = i == i' - exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x' exp (HsOverLit _ l) (HsOverLit _ l') = -- Overloaded lits are equal if they have the same type -- and the data is the same. @@ -1133,8 +1132,17 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 --------- ev_term :: EvTerm -> EvTerm -> Bool - ev_term (EvExpr (Var a)) (EvExpr (Var b)) = a==b - ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b + ev_term (EvExpr (Var a)) (EvExpr (Var b)) + = idType a `eqType` idType b + -- The /type/ of the evidence matters, not its precise proof term. + -- Caveat: conceivably a sufficiently exotic use of incoherent instances + -- could make a difference, but remember this is only used within the + -- pattern matches for a single function, so it's hard to see how that + -- could really happen. And we don't want accidentally different proofs + -- to prevent spotting equalities, and hence degrade pattern-match + -- overlap checking. + ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) + = a `eqCoercion` b ev_term _ _ = False --------- diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 6e9409989a..f4021d2e29 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -335,13 +335,19 @@ warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) -- ^ See if the expression is an 'Integral' literal. --- Remember to look through automatically-added tick-boxes! (#8384) -getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit -getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit -getLHsIntegralLit _ = Nothing +getLHsIntegralLit (L _ e) = go e + where + go (HsPar _ e) = getLHsIntegralLit e + go (HsOverLit _ over_lit) = getIntegralLit over_lit + go (HsLit _ lit) = getSimpleIntegralLit lit + + -- Remember to look through automatically-added tick-boxes! (#8384) + go (HsTick _ _ e) = getLHsIntegralLit e + go (HsBinTick _ _ _ e) = getLHsIntegralLit e + + -- The literal might be wrapped in a case with -XOverloadedLists + go (XExpr (WrapExpr (HsWrap _ e))) = go e + go _ = Nothing -- | If 'Integral', extract the value and type of the overloaded literal. -- See Note [Literals and the OverloadedLists extension] diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 42e0baca5e..0de212ba8e 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -87,6 +87,8 @@ import GHC.Types.Name.Env import GHC.TypeLits import Data.Kind (Constraint) +import qualified GHC.LanguageExtensions as LangExt + import Data.ByteString ( unpack ) import Control.Monad import Data.List (sort, sortBy) @@ -1482,7 +1484,7 @@ repE (HsVar _ (L _ x)) = Just (DsSplice e) -> do { e' <- lift $ dsExpr e ; return (MkC e') } } repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar -repE (HsOverLabel _ _ s) = repOverLabel s +repE (HsOverLabel _ s) = repOverLabel s repE e@(HsRecFld _ f) = case f of Unambiguous x _ -> repE (HsVar noExtField (noLoc x)) @@ -1554,7 +1556,7 @@ repE e@(HsDo _ ctxt (L _ sts)) | otherwise = notHandled "monad comprehension and [: :]" (ppr e) -repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } +repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitTuple _ es boxity) = let tupArgToCoreExp :: LHsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp))) tupArgToCoreExp (L _ a) @@ -1614,9 +1616,37 @@ repE (HsUnboundVar _ uv) = do occ <- occNameLit uv sname <- repNameS occ repUnboundVar sname -repE (XExpr (HsExpanded _ b)) = repE b -repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e) -repE e = notHandled "Expression form" (ppr e) +repE (XExpr (HsExpanded orig_expr ds_expr)) + = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax + ; if rebindable_on -- See Note [Quotation and rebindable syntax] + then repE ds_expr + else repE orig_expr } + +repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled "Cost centres" (ppr e) +repE e = notHandled "Expression form" (ppr e) + +{- Note [Quotation and rebindable syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = [| (* 3) |] + +Because of Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr, +the renamer will expand (* 3) to (rightSection (*) 3), regardless of RebindableSyntax. +Then, concerning the TH quotation, + +* If RebindableSyntax is off, we want the TH quote to generate the section (* 3), + as the user originally wrote. + +* If RebindableSyntax is on, we perhaps want the TH quote to generate + (rightSection (*) 3), using whatever 'rightSection' is in scope, because + (a) RebindableSyntax might not be on in the splicing context + (b) Even if it is, 'rightSection' might not be in scope + (c) At least in the case of Typed Template Haskell we should never get + 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). +-} ----------------------------------------------------------------------------- -- Building representations of auxiliary structures like Match, Clause, Stmt, diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 684ae41e65..dfa0b91e9b 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -720,7 +720,7 @@ instance HiePass p => HasType (Located (HsExpr (GhcPass p))) where HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) - ExplicitList ty _ _ -> Just (mkListTy ty) + ExplicitList ty _ -> Just (mkListTy ty) ExplicitSum ty _ _ _ -> Just (mkSumTy ty) HsDo ty _ _ -> Just ty HsMultiIf ty _ -> Just ty @@ -1043,7 +1043,7 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where HsRecFld _ fld -> [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) ] - HsOverLabel _ _ _ -> [] + HsOverLabel {} -> [] HsIPVar _ _ -> [] HsOverLit _ _ -> [] HsLit _ _ -> [] @@ -1106,7 +1106,7 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where [ locOnly ispan , toHie $ listScopes NoScope stmts ] - ExplicitList _ _ exprs -> + ExplicitList _ exprs -> [ toHie exprs ] RecordCon { rcon_con = con, rcon_flds = binds} -> diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 4018155d81..1b2cc3eead 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -2837,7 +2837,7 @@ aexp2 :: { ECP } | qcon { ECP $ mkHsVarPV $! $1 } -- See Note [%shift: aexp2 -> ipvar] | ipvar %shift { ecpFromExp $ sL1 $1 (HsIPVar noExtField $! unLoc $1) } - | overloaded_label { ecpFromExp $ sL1 $1 (HsOverLabel noExtField Nothing $! unLoc $1) } + | overloaded_label { ecpFromExp $ sL1 $1 (HsOverLabel noExtField $! unLoc $1) } | literal { ECP $ mkHsLitPV $! $1 } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -foverloaded-strings is on. diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index d5be2fdaad..4b02077c9c 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1482,7 +1482,7 @@ instance DisambECP (HsExpr GhcPs) where mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a) mkHsWildCardPV l = return $ L l hsHoleExpr mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (hsTypeToHsSigWcType sig)) - mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs) + mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField xs) mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp mkHsRecordPV l lrec a (fbinds, ddLoc) = do r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc) 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. diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index 5b34952d65..29dc16ab07 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -17,10 +17,9 @@ module GHC.Tc.Gen.App ( tcApp , tcInferSigma - , tcValArg , tcExprPrag ) where -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExprNC ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) import GHC.Builtin.Types (multiplicityTy) import GHC.Tc.Gen.Head @@ -137,13 +136,13 @@ tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType -- True <=> instantiate -- return a rho-type -- False <=> don't instantiate -- return a sigma-type tcInferSigma inst (L loc rn_expr) - | (rn_fun, rn_args, _) <- splitHsApps rn_expr + | (fun@(rn_fun,_), rn_args) <- splitHsApps rn_expr = addExprCtxt rn_expr $ setSrcSpan loc $ do { do_ql <- wantQuickLook rn_fun - ; (tc_fun, fun_sigma) <- tcInferAppHead rn_fun rn_args Nothing - ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst rn_fun fun_sigma rn_args - ; _tc_args <- tcValArgs do_ql tc_fun inst_args + ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args Nothing + ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst fun fun_sigma rn_args + ; _tc_args <- tcValArgs do_ql inst_args ; return app_res_sigma } {- ********************************************************************* @@ -168,6 +167,7 @@ app :: head head ::= f -- HsVar: variables | fld -- HsRecFld: record field selectors | (expr :: ty) -- ExprWithTySig: expr with user type sig + | lit -- HsOverLit: overloaded literals | other_expr -- Other expressions When tcExpr sees something that starts an application chain (namely, @@ -259,18 +259,33 @@ Some cases that /won't/ work: we'll delegate back to tcExpr, which will instantiate f's type and the type application to @Int will fail. Too bad! +Note [Quick Look for particular Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We switch on Quick Look (regardless of -XImpredicativeTypes) for certain +particular Ids: + +* ($): For a long time GHC has had a special typing rule for ($), that + allows it to type (runST $ foo), which requires impredicative instantiation + of ($), without language flags. It's a bit ad-hoc, but it's been that + way for ages. Using quickLookIds is the only special treatment ($) needs + now, which is a lot better. + +* leftSection, rightSection: these are introduced by the expansion step in + the renamer (Note [Handling overloaded and rebindable constructs] in + GHC.Rename.Expr), and we want them to be instantiated impredicatively + so that (f `op`), say, will work OK even if `f` is higher rank. -} tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -- See Note [tcApp: typechecking applications] tcApp rn_expr exp_res_ty - | (rn_fun, rn_args, rebuild) <- splitHsApps rn_expr - = do { (tc_fun, fun_sigma) <- tcInferAppHead rn_fun rn_args + | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr + = do { (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args (checkingExpType_maybe exp_res_ty) -- Instantiate ; do_ql <- wantQuickLook rn_fun - ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True rn_fun fun_sigma rn_args + ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args -- Quick look at result ; quickLookResultType do_ql delta app_res_rho exp_res_ty @@ -287,7 +302,7 @@ tcApp rn_expr exp_res_ty , text "rn_expr:" <+> ppr rn_expr ]) } -- Typecheck the value arguments - ; tc_args <- tcValArgs do_ql tc_fun inst_args + ; tc_args <- tcValArgs do_ql inst_args -- Zonk the result type, to ensure that we substitute out -- any filled-in instantiation variable before calling tcWrapResultMono @@ -300,21 +315,35 @@ tcApp rn_expr exp_res_ty -- Special case for tagToEnum# ; if isTagToEnum rn_fun - then tcTagToEnum rn_expr tc_fun tc_args app_res_rho exp_res_ty + then tcTagToEnum rn_expr tc_fun fun_ctxt tc_args app_res_rho exp_res_ty else do { -- Reconstruct - ; let tc_expr = rebuild tc_fun tc_args + ; let tc_expr = rebuildHsApps tc_fun fun_ctxt tc_args + + -- Set a context for the helpful + -- "Probably cause: f applied to too many args" + -- But not in generated code, where we don't want + -- to mention internal (rebindable syntax) function names + set_res_ctxt thing_inside + | insideExpansion tc_args + = thing_inside + | otherwise + = addFunResCtxt tc_fun tc_args app_res_rho exp_res_ty thing_inside -- Wrap the result - ; addFunResCtxt tc_fun tc_args app_res_rho exp_res_ty $ - tcWrapResultMono rn_expr tc_expr app_res_rho exp_res_ty } } + ; set_res_ctxt $ tcWrapResultMono rn_expr tc_expr app_res_rho exp_res_ty } } -------------------- wantQuickLook :: HsExpr GhcRn -> TcM Bool -- GHC switches on impredicativity all the time for ($) -wantQuickLook (HsVar _ f) | unLoc f `hasKey` dollarIdKey = return True -wantQuickLook _ = xoptM LangExt.ImpredicativeTypes +wantQuickLook (HsVar _ (L _ f)) + | getUnique f `elem` quickLookKeys = return True +wantQuickLook _ = xoptM LangExt.ImpredicativeTypes + +quickLookKeys :: [Unique] +-- See Note [Quick Look for particular Ids] +quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey] zonkQuickLook :: Bool -> TcType -> TcM TcType -- After all Quick Look unifications are done, zonk to ensure that all @@ -343,24 +372,18 @@ zonkArg arg = return arg ---------------- tcValArgs :: Bool -- Quick-look on? - -> HsExpr GhcTc -- The function (for error messages) -> [HsExprArg 'TcpInst] -- Actual argument -> TcM [HsExprArg 'TcpTc] -- Resulting argument -tcValArgs do_ql fun args - = go 1 args +tcValArgs do_ql args + = mapM tc_arg args where - go _ [] = return [] - go n (arg:args) = do { (n',arg') <- tc_arg n arg - ; args' <- go n' args - ; return (arg' : args') } - - tc_arg :: Int -> HsExprArg 'TcpInst -> TcM (Int, HsExprArg 'TcpTc) - tc_arg n (EPar l) = return (n, EPar l) - tc_arg n (EPrag l p) = return (n, EPrag l (tcExprPrag p)) - tc_arg n (EWrap wrap) = return (n, EWrap wrap) - tc_arg n (ETypeArg l hs_ty ty) = return (n+1, ETypeArg l hs_ty ty) - - tc_arg n eva@(EValArg { eva_arg = arg, eva_arg_ty = Scaled mult arg_ty }) + tc_arg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpTc) + tc_arg (EPrag l p) = return (EPrag l (tcExprPrag p)) + tc_arg (EWrap w) = return (EWrap w) + tc_arg (ETypeArg l hs_ty ty) = return (ETypeArg l hs_ty ty) + + tc_arg eva@(EValArg { eva_arg = arg, eva_arg_ty = Scaled mult arg_ty + , eva_ctxt = ctxt }) = do { -- Crucial step: expose QL results before checking arg_ty -- So far as the paper is concerned, this step applies -- the poly-substitution Theta, learned by QL, so that we @@ -373,47 +396,34 @@ tcValArgs do_ql fun args arg_ty <- zonkQuickLook do_ql arg_ty -- Now check the argument - ; arg' <- addErrCtxt (funAppCtxt fun (eValArgExpr arg) n) $ - tcScalingUsage mult $ + ; arg' <- tcScalingUsage mult $ do { traceTc "tcEValArg" $ - vcat [ ppr n <+> text "of" <+> ppr fun + vcat [ ppr ctxt , text "arg type:" <+> ppr arg_ty , text "arg:" <+> ppr arg ] - ; tcEValArg arg arg_ty } + ; tcEValArg ctxt arg arg_ty } - ; return (n+1, eva { eva_arg = ValArg arg' - , eva_arg_ty = Scaled mult arg_ty }) } + ; return (eva { eva_arg = ValArg arg' + , eva_arg_ty = Scaled mult arg_ty }) } -tcEValArg :: EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc) +tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc) -- Typecheck one value argument of a function call -tcEValArg (ValArg arg) exp_arg_sigma - = tcCheckPolyExprNC arg exp_arg_sigma - -tcEValArg (ValArgQL { va_expr = L loc _, va_fun = fun, va_args = args - , va_ty = app_res_rho, va_rebuild = rebuild }) exp_arg_sigma - = setSrcSpan loc $ - do { traceTc "tcEValArg {" (vcat [ ppr fun <+> ppr args ]) - ; tc_args <- tcValArgs True fun args - ; co <- unifyType Nothing app_res_rho exp_arg_sigma +tcEValArg ctxt (ValArg larg@(L arg_loc arg)) exp_arg_sigma + = addArgCtxt ctxt larg $ + do { arg' <- tcPolyExpr arg (mkCheckExpType exp_arg_sigma) + ; return (L arg_loc arg') } + +tcEValArg ctxt (ValArgQL { va_expr = larg@(L arg_loc _) + , va_fun = (inner_fun, fun_ctxt) + , va_args = inner_args + , va_ty = app_res_rho }) exp_arg_sigma + = addArgCtxt ctxt larg $ + do { traceTc "tcEValArgQL {" (vcat [ ppr inner_fun <+> ppr inner_args ]) + ; tc_args <- tcValArgs True inner_args + ; co <- unifyType Nothing app_res_rho exp_arg_sigma ; traceTc "tcEValArg }" empty - ; return (L loc $ mkHsWrapCo co $ rebuild fun tc_args) } - ----------------- -tcValArg :: HsExpr GhcRn -- The function (for error messages) - -> LHsExpr GhcRn -- Actual argument - -> Scaled TcSigmaType -- expected arg type - -> Int -- # of argument - -> TcM (LHsExpr GhcTc) -- Resulting argument --- tcValArg is called only from Gen.Expr, dealing with left and right sections -tcValArg fun arg (Scaled mult arg_ty) arg_no - = addErrCtxt (funAppCtxt fun arg arg_no) $ - tcScalingUsage mult $ - do { traceTc "tcValArg" $ - vcat [ ppr arg_no <+> text "of" <+> ppr fun - , text "arg type:" <+> ppr arg_ty - , text "arg:" <+> ppr arg ] - ; tcCheckPolyExprNC arg arg_ty } - + ; return (L arg_loc $ mkHsWrapCo co $ + rebuildHsApps inner_fun fun_ctxt tc_args) } {- ********************************************************************* * * @@ -435,18 +445,33 @@ tcInstFun :: Bool -- True <=> Do quick-look -- in tcInferSigma, which is used only to implement :type -- Otherwise we do eager instantiation; in Fig 5 of the paper -- |-inst returns a rho-type - -> HsExpr GhcRn -> TcSigmaType -> [HsExprArg 'TcpRn] + -> (HsExpr GhcRn, AppCtxt) -- Error messages only + -> TcSigmaType -> [HsExprArg 'TcpRn] -> TcM ( Delta , [HsExprArg 'TcpInst] , TcSigmaType ) -- This function implements the |-inst judgement in Fig 4, plus the -- modification in Fig 5, of the QL paper: -- "A quick look at impredicativity" (ICFP'20). -tcInstFun do_ql inst_final rn_fun fun_sigma rn_args - = do { traceTc "tcInstFun" (ppr rn_fun $$ ppr rn_args $$ text "do_ql" <+> ppr do_ql) +tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args + = do { traceTc "tcInstFun" (vcat [ ppr rn_fun, ppr fun_sigma + , text "args:" <+> ppr rn_args + , text "do_ql" <+> ppr do_ql ]) ; go emptyVarSet [] [] fun_sigma rn_args } where - fun_orig = exprCtOrigin rn_fun + fun_loc = appCtxtLoc fun_ctxt + fun_orig = exprCtOrigin (case fun_ctxt of + VAExpansion e _ -> e + VACall e _ _ -> e) + set_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 + herald = sep [ text "The function" <+> quotes (ppr rn_fun) , text "is applied to"] @@ -497,13 +522,14 @@ tcInstFun do_ql inst_final rn_fun fun_sigma rn_args -- ('go' dealt with that case) -- Rule IALL from Fig 4 of the QL paper + -- c.f. GHC.Tc.Utils.Instantiate.topInstantiate go1 delta acc so_far fun_ty args | (tvs, body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty , (theta, body2) <- tcSplitPhiTy body1 , not (null tvs && null theta) - = do { (inst_tvs, wrap, fun_rho) <- setSrcSpanFromArgs rn_args $ + = do { (inst_tvs, wrap, fun_rho) <- set_fun_ctxt $ instantiateSigma fun_orig tvs theta body2 - -- setSrcSpanFromArgs: important for the class constraints + -- set_fun_ctxt: important for the class constraints -- that may be emitted from instantiating fun_sigma ; go (delta `extendVarSetList` inst_tvs) (addArgWrap wrap acc) so_far fun_rho args } @@ -515,21 +541,21 @@ tcInstFun do_ql inst_final rn_fun fun_sigma rn_args = do { traceTc "tcInstFun:ret" (ppr fun_ty) ; return (delta, reverse acc, fun_ty) } - go1 delta acc so_far fun_ty (EPar sp : args) - = go1 delta (EPar sp : acc) so_far fun_ty args + go1 delta acc so_far fun_ty (EWrap w : args) + = go1 delta (EWrap w : acc) so_far fun_ty args go1 delta acc so_far fun_ty (EPrag sp prag : args) = go1 delta (EPrag sp prag : acc) so_far fun_ty args -- Rule ITYARG from Fig 4 of the QL paper - go1 delta acc so_far fun_ty ( ETypeArg { eva_loc = loc, eva_hs_ty = hs_ty } + go1 delta acc so_far fun_ty ( ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty } : rest_args ) | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] = go delta acc so_far fun_ty rest_args | otherwise = do { (ty_arg, inst_ty) <- tcVTA fun_ty hs_ty - ; let arg' = ETypeArg { eva_loc = loc, eva_hs_ty = hs_ty, eva_ty = ty_arg } + ; let arg' = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty, eva_ty = ty_arg } ; go delta (arg' : acc) so_far inst_ty rest_args } -- Rule IVAR from Fig 4 of the QL paper: @@ -573,15 +599,12 @@ tcInstFun do_ql inst_final rn_fun 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 }) : rest_args) + (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args) = do { (wrap, arg_ty, res_ty) <- matchActualFunTySigma herald (Just (ppr rn_fun)) (n_val_args, so_far) fun_ty - ; let arg_no = 1 + count isVisibleArg acc - -- We could cache this in a pair with acc; but - -- it's only evaluated if there's a type error ; (delta', arg') <- if do_ql - then addErrCtxt (funAppCtxt rn_fun arg arg_no) $ + then addArgCtxt ctxt arg $ -- Context needed for constraints -- generated by calls in arg quickLookArg delta arg arg_ty @@ -591,6 +614,21 @@ tcInstFun do_ql inst_final rn_fun fun_sigma rn_args ; go delta' acc' (arg_ty:so_far) res_ty rest_args } +addArgCtxt :: AppCtxt -> LHsExpr GhcRn + -> TcM a -> TcM a +-- Adds a "In the third argument of f, namely blah" +-- context, unless we are in generated code, in which case +-- use "In the expression: arg" +---See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr +addArgCtxt (VACall fun arg_no _) (L arg_loc arg) thing_inside + = setSrcSpan arg_loc $ + addErrCtxt (funAppCtxt fun arg arg_no) $ + thing_inside + +addArgCtxt (VAExpansion {}) (L arg_loc arg) thing_inside + = setSrcSpan arg_loc $ + addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated + thing_inside {- ********************************************************************* * * @@ -756,7 +794,7 @@ quickLookArg delta larg (Scaled _ arg_ty) | isEmptyVarSet delta = skipQuickLook delta larg | otherwise = go arg_ty where - guarded = isGuardedTy arg_ty + guarded = isGuardedTy arg_ty -- NB: guardedness is computed based on the original, -- unzonked arg_ty, so we deliberately do not exploit -- guardedness that emerges a result of QL on earlier args @@ -785,9 +823,8 @@ isGuardedTy ty quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaType -> TcM (Delta, EValArg 'TcpInst) -quickLookArg1 guarded delta larg@(L loc arg) arg_ty - = setSrcSpan loc $ - do { let (rn_fun,rn_args,rebuild) = splitHsApps arg +quickLookArg1 guarded delta larg@(L _ arg) arg_ty + = do { let (fun@(rn_fun, fun_ctxt), rn_args) = splitHsApps arg ; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args (Just arg_ty) ; traceTc "quickLookArg 1" $ vcat [ text "arg:" <+> ppr arg @@ -797,19 +834,20 @@ quickLookArg1 guarded delta larg@(L loc arg) arg_ty ; case mb_fun_ty of { Nothing -> -- fun is too complicated skipQuickLook delta larg ; - Just (fun', fun_sigma) -> + Just (tc_fun, fun_sigma) -> do { let no_free_kappas = findNoQuantVars fun_sigma rn_args ; traceTc "quickLookArg 2" $ vcat [ text "no_free_kappas:" <+> ppr no_free_kappas - , text "guarded:" <+> ppr guarded ] + , text "guarded:" <+> ppr guarded + , text "tc_fun:" <+> ppr tc_fun + , text "fun_sigma:" <+> ppr fun_sigma ] ; if not (guarded || no_free_kappas) then skipQuickLook delta larg else do { do_ql <- wantQuickLook rn_fun - ; (delta_app, inst_args, app_res_rho) - <- tcInstFun do_ql True rn_fun fun_sigma rn_args - ; traceTc "quickLookArg" $ + ; (delta_app, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args + ; traceTc "quickLookArg 3" $ vcat [ text "arg:" <+> ppr arg , text "delta:" <+> ppr delta , text "delta_app:" <+> ppr delta_app @@ -821,10 +859,10 @@ quickLookArg1 guarded delta larg@(L loc arg) arg_ty ; let delta' = delta `unionVarSet` delta_app ; qlUnify delta' arg_ty app_res_rho - ; let ql_arg = ValArgQL { va_expr = larg, va_fun = fun' - , va_args = inst_args - , va_ty = app_res_rho - , va_rebuild = rebuild } + ; let ql_arg = ValArgQL { va_expr = larg + , va_fun = (tc_fun, fun_ctxt) + , va_args = inst_args + , va_ty = app_res_rho } ; return (delta', ql_arg) } } } } skipQuickLook :: Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst) @@ -1013,7 +1051,7 @@ findNoQuantVars fun_ty args go bvs fun_ty [] = tyCoVarsOfType fun_ty `disjointVarSet` bvs - go bvs fun_ty (EPar {} : args) = go bvs fun_ty args + go bvs fun_ty (EWrap {} : args) = go bvs fun_ty args go bvs fun_ty (EPrag {} : args) = go bvs fun_ty args go bvs fun_ty args@(ETypeArg {} : rest_args) @@ -1071,12 +1109,13 @@ isTagToEnum :: HsExpr GhcRn -> Bool isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey isTagToEnum _ = False -tcTagToEnum :: HsExpr GhcRn -> HsExpr GhcTc -> [HsExprArg 'TcpTc] +tcTagToEnum :: HsExpr GhcRn + -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> TcRhoType -> ExpRhoType -> TcM (HsExpr GhcTc) -- tagToEnum# :: forall a. Int# -> a -- See Note [tagToEnum#] Urgh! -tcTagToEnum expr fun args app_res_ty res_ty +tcTagToEnum expr fun fun_ctxt args app_res_ty res_ty | null val_args = failWithTc (text "tagToEnum# must appear applied to one argument") @@ -1101,7 +1140,7 @@ tcTagToEnum expr fun args app_res_ty res_ty check_enumeration ty' rep_tc ; let rep_ty = mkTyConApp rep_tc rep_args fun' = mkHsWrap (WpTyApp rep_ty) fun - expr' = rebuildPrefixApps fun' val_args + expr' = rebuildHsApps fun' fun_ctxt val_args df_wrap = mkWpCastR (mkTcSymCo coi) ; return (mkHsWrap df_wrap expr') }}}}} @@ -1109,7 +1148,7 @@ tcTagToEnum expr fun args app_res_ty res_ty val_args = dropWhile (not . isHsValArg) args vanilla_result - = do { let expr' = rebuildPrefixApps fun args + = do { let expr' = rebuildHsApps fun fun_ctxt args ; tcWrapResultMono expr expr' app_res_ty res_ty } check_enumeration ty' tc diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 7d7b34e9d3..8ad1e59796 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -17,9 +17,10 @@ module GHC.Tc.Gen.Expr ( tcCheckPolyExpr, tcCheckPolyExprNC, - tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC, + tcCheckMonoExpr, tcCheckMonoExprNC, + tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, - tcExpr, + tcPolyExpr, tcExpr, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, addAmbiguousNameErr, @@ -37,7 +38,6 @@ import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic -import GHC.Types.SourceText import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Utils.Instantiate @@ -81,7 +81,6 @@ import GHC.Data.FastString import Control.Monad import GHC.Core.Class(classTyCon) import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet ) -import qualified GHC.LanguageExtensions as LangExt import Data.Function import Data.List (partition, sortBy, groupBy, intersect) @@ -105,34 +104,23 @@ tcCheckPolyExpr, tcCheckPolyExprNC -- The NC version does not do so, usually because the caller wants -- to do so themselves. -tcCheckPolyExpr expr res_ty = tcPolyExpr expr (mkCheckExpType res_ty) -tcCheckPolyExprNC expr res_ty = tcPolyExprNC expr (mkCheckExpType res_ty) +tcCheckPolyExpr expr res_ty = tcPolyLExpr expr (mkCheckExpType res_ty) +tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty) -- These versions take an ExpType -tcPolyExpr, tcPolyExprNC - :: LHsExpr GhcRn -> ExpSigmaType - -> TcM (LHsExpr GhcTc) +tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType + -> TcM (LHsExpr GhcTc) -tcPolyExpr expr res_ty - = addLExprCtxt expr $ - do { traceTc "tcPolyExpr" (ppr res_ty) - ; tcPolyExprNC expr res_ty } - -tcPolyExprNC (L loc expr) res_ty - = set_loc_and_ctxt loc expr $ - do { traceTc "tcPolyExprNC" (ppr res_ty) - ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> - tcExpr expr res_ty - ; return $ L loc (mkHsWrap wrap expr') } +tcPolyLExpr (L loc expr) res_ty + = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { expr' <- tcPolyExpr expr res_ty + ; return (L loc expr') } - where -- See Note [Rebindable syntax and HsExpansion), which describes - -- the logic behind this location/context tweaking. - set_loc_and_ctxt l e m = do - inGenCode <- inGeneratedCode - if inGenCode && not (isGeneratedSrcSpan l) - then setSrcSpan l $ - addExprCtxt e m - else setSrcSpan l m +tcPolyLExprNC (L loc expr) res_ty + = setSrcSpan loc $ + do { expr' <- tcPolyExpr expr res_ty + ; return (L loc expr') } --------------- tcCheckMonoExpr, tcCheckMonoExprNC @@ -149,9 +137,11 @@ tcMonoExpr, tcMonoExprNC -- Definitely no foralls at the top -> TcM (LHsExpr GhcTc) -tcMonoExpr expr res_ty - = addLExprCtxt expr $ - tcMonoExprNC expr res_ty +tcMonoExpr (L loc expr) res_ty + = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } tcMonoExprNC (L loc expr) res_ty = setSrcSpan loc $ @@ -161,8 +151,11 @@ tcMonoExprNC (L loc expr) res_ty --------------- tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) -- Infer a *rho*-type. The return type is always instantiated. -tcInferRho le = addLExprCtxt le $ - tcInferRhoNC le +tcInferRho (L loc expr) + = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { (expr', rho) <- tcInfer (tcExpr expr) + ; return (L loc expr', rho) } tcInferRhoNC (L loc expr) = setSrcSpan loc $ @@ -176,22 +169,45 @@ tcInferRhoNC (L loc expr) * * ********************************************************************* -} +tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) +tcPolyExpr expr res_ty + = do { traceTc "tcPolyExpr" (ppr res_ty) + ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> + tcExpr expr res_ty + ; return $ mkHsWrap wrap expr' } + tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -- Use tcApp to typecheck appplications, which are treated specially -- by Quick Look. Specifically: --- - HsApp: value applications --- - HsTypeApp: type applications --- - HsVar: lone variables, to ensure that they can get an --- impredicative instantiation (via Quick Look --- driven by res_ty (in checking mode). --- - ExprWithTySig: (e :: type) +-- - HsVar lone variables, to ensure that they can get an +-- impredicative instantiation (via Quick Look +-- driven by res_ty (in checking mode)). +-- - HsApp value applications +-- - HsAppType type applications +-- - ExprWithTySig (e :: type) +-- - HsRecFld overloaded record fields +-- - HsExpanded renamer expansions +-- - HsOpApp operator applications +-- - HsOverLit overloaded literals +-- These constructors are the union of +-- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps +-- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe -- See Note [Application chains and heads] in GHC.Tc.Gen.App -tcExpr e@(HsVar {}) res_ty = tcApp e res_ty -tcExpr e@(HsApp {}) 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@(HsRecFld {}) res_ty = tcApp e res_ty +tcExpr e@(HsVar {}) res_ty = tcApp e res_ty +tcExpr e@(HsApp {}) res_ty = tcApp e res_ty +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@(HsRecFld {}) res_ty = tcApp e res_ty +tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty + +tcExpr e@(HsOverLit _ lit) res_ty + = do { mb_res <- tcShortCutLit lit res_ty + -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.Zonk + ; case mb_res of + Just lit' -> return (HsOverLit noExtField lit') + Nothing -> tcApp e res_ty } -- Typecheck an occurrence of an unbound Id -- @@ -216,10 +232,6 @@ tcExpr (HsPragE x prag expr) res_ty = do { expr' <- tcMonoExpr expr res_ty ; return (HsPragE x (tcExprPrag prag) expr') } -tcExpr (HsOverLit x lit) res_ty - = do { lit' <- newOverloadedLit lit res_ty - ; return (HsOverLit x lit') } - tcExpr (NegApp x expr neg_expr) res_ty = do { (expr', neg_expr') <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ @@ -245,31 +257,6 @@ tcExpr e@(HsIPVar _ x) res_ty unwrapIP $ mkClassPred ipClass [x,ty] origin = IPOccOrigin x -tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty - = do { -- See Note [Type-checking overloaded labels] - loc <- getSrcSpanM - ; case mb_fromLabel of - Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty - Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName - ; alpha <- newFlexiTyVarTy liftedTypeKind - ; let pred = mkClassPred isLabelClass [lbl, alpha] - ; loc <- getSrcSpanM - ; var <- emitWantedEvVar origin pred - ; tcWrapResult e - (fromDict pred (HsVar noExtField (L loc var))) - alpha res_ty } } - where - -- Coerces a dictionary for `IsLabel "x" t` into `t`, - -- or `HasField "x" r a into `r -> a`. - fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred - origin = OverLabelOrigin l - lbl = mkStrLitTy l - - applyFromLabel loc fromLabel = - HsAppType noExtField - (L loc (HsVar noExtField (L loc fromLabel))) - (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l)))) - tcExpr (HsLam x match) res_ty = do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty ; return (mkHsWrap wrap (HsLam x match')) } @@ -292,92 +279,26 @@ tcExpr e@(HsLamCase x matches) res_ty , text "requires"] match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -{- -Note [Type-checking overloaded labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recall that we have - - module GHC.OverloadedLabels where - class IsLabel (x :: Symbol) a where - fromLabel :: a - -We translate `#foo` to `fromLabel @"foo"`, where we use - - * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not - * `GHC.OverloadedLabels.fromLabel`. - -In the `RebindableSyntax` case, the renamer will have filled in the -first field of `HsOverLabel` with the `fromLabel` function to use, and -we simply apply it to the appropriate visible type argument. - -In the `OverloadedLabels` case, when we see an overloaded label like -`#foo`, we generate a fresh variable `alpha` for the type and emit an -`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a -single method, it is represented by a newtype, so we can coerce -`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters). - --} {- ************************************************************************ * * - Infix operators and sections + Explicit lists * * ************************************************************************ - -Note [Left sections] -~~~~~~~~~~~~~~~~~~~~ -Left sections, like (4 *), are equivalent to - \ x -> (*) 4 x, -or, if PostfixOperators is enabled, just - (*) 4 -With PostfixOperators we don't actually require the function to take -two arguments at all. For example, (x `not`) means (not x); you get -postfix operators! Not Haskell 98, but it's less work and kind of -useful. -} -tcExpr expr@(OpApp {}) res_ty - = tcApp expr res_ty - --- Right sections, equivalent to \ x -> x `op` expr, or --- \ x -> op x expr - -tcExpr expr@(SectionR x op arg2) res_ty - = do { (op', op_ty) <- tcInferRhoNC op - ; (wrap_fun, [Scaled arg1_mult arg1_ty, arg2_ty], op_res_ty) - <- matchActualFunTysRho (mk_op_msg op) fn_orig - (Just (ppr op)) 2 op_ty - ; arg2' <- tcValArg (unLoc op) arg2 arg2_ty 2 - ; let expr' = SectionR x (mkLHsWrap wrap_fun op') arg2' - act_res_ty = mkVisFunTy arg1_mult arg1_ty op_res_ty - ; tcWrapResultMono expr expr' act_res_ty res_ty } - - where - fn_orig = lexprCtOrigin op - -- It's important to use the origin of 'op', so that call-stacks - -- come out right; they are driven by the OccurrenceOf CtOrigin - -- See #13285 - -tcExpr expr@(SectionL x arg1 op) res_ty - = do { (op', op_ty) <- tcInferRhoNC op - ; dflags <- getDynFlags -- Note [Left sections] - ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1 - | otherwise = 2 - - ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) - <- matchActualFunTysRho (mk_op_msg op) fn_orig - (Just (ppr op)) n_reqd_args op_ty - ; arg1' <- tcValArg (unLoc op) arg1 arg1_ty 1 - ; let expr' = SectionL x arg1' (mkLHsWrap wrap_fn op') - act_res_ty = mkVisFunTys arg_tys op_res_ty - ; tcWrapResultMono expr expr' act_res_ty res_ty } - where - fn_orig = lexprCtOrigin op - -- It's important to use the origin of 'op', so that call-stacks - -- come out right; they are driven by the OccurrenceOf CtOrigin - -- See #13285 +-- Explict lists [e1,e2,e3] have been expanded already in the renamer +-- The expansion includes an ExplicitList, but it is always the built-in +-- list type, so that's all we need concern ourselves with here. See +-- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs] +tcExpr (ExplicitList _ exprs) res_ty + = do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedListTy res_ty + ; let tc_elt expr = tcCheckPolyExpr expr elt_ty + ; exprs' <- mapM tc_elt exprs + ; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' } tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty | all tupArgPresent tup_args @@ -427,32 +348,6 @@ tcExpr (ExplicitSum _ alt arity expr) res_ty ; expr' <- tcCheckPolyExpr expr (arg_tys' `getNth` (alt - 1)) ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } --- This will see the empty list only when -XOverloadedLists. --- See Note [Empty lists] in GHC.Hs.Expr. -tcExpr (ExplicitList _ witness exprs) res_ty - = case witness of - Nothing -> do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ - mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' } - - Just fln -> do { ((exprs', elt_ty), fln') - <- tcSyntaxOp ListOrigin fln - [synKnownType intTy, SynList] res_ty $ - \ [elt_ty] [_int_mul, list_mul] -> - -- We ignore _int_mul because the integer (first - -- argument of fromListN) is statically known: it - -- is desugared to a literal. Therefore there is - -- no variable of which to scale the usage in that - -- first argument, and `_int_mul` is completely - -- free in this expression. - do { exprs' <- - mapM (tcScalingUsage list_mul . tc_elt elt_ty) exprs - ; return (exprs', elt_ty) } - - ; return $ ExplicitList elt_ty (Just fln') exprs' } - where tc_elt elt_ty expr = tcCheckPolyExpr expr elt_ty {- ************************************************************************ @@ -955,27 +850,18 @@ tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty {- ************************************************************************ * * - Rebindable syntax -* * -************************************************************************ --} - --- See Note [Rebindable syntax and HsExpansion]. -tcExpr (XExpr (HsExpanded a b)) t - = fmap (XExpr . ExpansionExpr . HsExpanded a) $ - setSrcSpan generatedSrcSpan (tcExpr b t) - -{- -************************************************************************ -* * Catch-all * * ************************************************************************ -} -tcExpr other _ = pprPanic "tcExpr" (ppr other) - -- Include ArrForm, ArrApp, which shouldn't appear at all - -- Also HsTcBracketOut, HsQuasiQuoteE +tcExpr (HsConLikeOut {}) ty = pprPanic "tcExpr:HsConLikeOut" (ppr ty) +tcExpr (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty) +tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty) +tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty) +tcExpr (HsTcBracketOut {}) ty = pprPanic "tcExpr:HsTcBracketOut" (ppr ty) +tcExpr (HsTick {}) ty = pprPanic "tcExpr:HsTick" (ppr ty) +tcExpr (HsBinTick {}) ty = pprPanic "tcExpr:HsBinTick" (ppr ty) {- @@ -1076,9 +962,8 @@ tcSyntaxOpGen :: CtOrigin -> ([TcSigmaType] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside - = do { (expr, sigma) <- tcInferAppHead op [] Nothing - -- Nothing here might be improved, but all this - -- code is scheduled for demolition anyway + = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) [] Nothing + -- Ugh!! But all this code is scheduled for demolition anyway ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) ; (result, expr_wrap, arg_wraps, res_wrap) <- tcSynArgA orig sigma arg_tys res_ty $ @@ -1391,8 +1276,8 @@ For each binding field = value 3. Instantiate the field type (from the field label) using the type envt from step 2. -4 Type check the value using tcValArg, passing the field type as - the expected argument type. +4 Type check the value using tcCheckPolyExprNC (in tcRecordField), + passing the field type as the expected argument type. This extends OK when the field types are universally quantified. -} @@ -1540,9 +1425,6 @@ fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") -mk_op_msg :: LHsExpr GhcRn -> SDoc -mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" - badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc badFieldTypes prs = hang (text "Record update for insufficiently polymorphic field" diff --git a/compiler/GHC/Tc/Gen/Expr.hs-boot b/compiler/GHC/Tc/Gen/Expr.hs-boot index b47b146118..22abe79491 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs-boot +++ b/compiler/GHC/Tc/Gen/Expr.hs-boot @@ -1,7 +1,8 @@ module GHC.Tc.Gen.Expr where import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn , SyntaxExprTc ) -import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) +import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType + , ExpType, ExpRhoType, ExpSigmaType ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Core.Type ( Mult ) @@ -21,7 +22,8 @@ tcCheckMonoExpr, tcCheckMonoExprNC :: -> TcRhoType -> TcM (LHsExpr GhcTc) -tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) +tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 3d6d51ff22..7dc993d8cc 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -16,10 +16,10 @@ -} module GHC.Tc.Gen.Head - ( HsExprArg(..), EValArg(..), TcPass(..), Rebuilder - , splitHsApps - , addArgWrap, eValArgExpr, isHsValArg, setSrcSpanFromArgs - , countLeadingValArgs, isVisibleArg, pprHsExprArgTc, rebuildPrefixApps + ( HsExprArg(..), EValArg(..), TcPass(..), AppCtxt(..), appCtxtLoc + , splitHsApps, rebuildHsApps + , addArgWrap, isHsValArg, insideExpansion + , countLeadingValArgs, isVisibleArg, pprHsExprArgTc , tcInferAppHead, tcInferAppHead_maybe , tcInferId, tcCheckId @@ -27,7 +27,7 @@ module GHC.Tc.Gen.Head , tyConOf, tyConOfET, lookupParents, fieldNotInType , notSelector, nonBidirectionalErr - , addExprCtxt, addLExprCtxt, addFunResCtxt ) where + , addExprCtxt, addFunResCtxt ) where import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC ) @@ -47,6 +47,7 @@ import GHC.Rename.Env ( addUsedGRE ) import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr ) import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Zonk ( hsLitType ) import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType @@ -134,20 +135,24 @@ Invariants: under the conditions when quick-look should happen (eg the argument type is guarded) -- see quickLookArg -Note [splitHsApps and Rebuilder] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [splitHsApps] +~~~~~~~~~~~~~~~~~~ The key function - splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, [HsExprArg 'TcpRn], Rebuilder) + splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, HsExpr GhcRn, [HsExprArg 'TcpRn]) takes apart either an HsApp, or an infix OpApp, returning -* The "head" of the application, an expression that is often a variable +* The "head" of the application, an expression that is often a variable; + this is used for typechecking -* A list of HsExprArg, the arguments +* 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 + (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". -* A Rebuilder function which reconstructs the original form, given the - head and arguments. This allows us to reconstruct infix - applications (OpApp) as well as prefix applications (HsApp), - thereby retaining the structure of the original tree. +* A list of HsExprArg, the arguments -} data TcPass = TcpRn -- Arguments decomposed @@ -156,34 +161,52 @@ data TcPass = TcpRn -- Arguments decomposed data HsExprArg (p :: TcPass) = -- See Note [HsExprArg] - EValArg { eva_loc :: SrcSpan -- Of the function + EValArg { eva_ctxt :: AppCtxt , eva_arg :: EValArg p , eva_arg_ty :: !(XEVAType p) } - | ETypeArg { eva_loc :: SrcSpan -- Of the function + | ETypeArg { eva_ctxt :: AppCtxt , eva_hs_ty :: LHsWcType GhcRn -- The type arg , eva_ty :: !(XETAType p) } -- Kind-checked type arg - | EPrag SrcSpan + | EPrag AppCtxt (HsPragE (GhcPass (XPass p))) - | EPar SrcSpan -- Of the nested expr + | EWrap EWrap - | EWrap !(XEWrap p) -- Wrapper, after instantiation +data EWrap = EPar AppCtxt + | EExpand (HsExpr GhcRn) + | EHsWrap HsWrapper data EValArg (p :: TcPass) where -- See Note [EValArg] ValArg :: LHsExpr (GhcPass (XPass p)) -> EValArg p - ValArgQL :: { va_expr :: LHsExpr GhcRn -- Original expression + + ValArgQL :: { va_expr :: LHsExpr GhcRn -- Original application -- For location and error msgs - , va_fun :: HsExpr GhcTc -- Function, typechecked + , va_fun :: (HsExpr GhcTc, AppCtxt) -- Function of the application, + -- typechecked, plus its context , va_args :: [HsExprArg 'TcpInst] -- Args, instantiated - , va_ty :: TcRhoType -- Result type - , va_rebuild :: Rebuilder } -- How to reassemble + , va_ty :: TcRhoType } -- Result type -> EValArg 'TcpInst -- Only exists in TcpInst phase -type Rebuilder = HsExpr GhcTc -> [HsExprArg 'TcpTc]-> HsExpr GhcTc --- See Note [splitHsApps and Rebuilder] +data AppCtxt + = VAExpansion + (HsExpr GhcRn) -- Inside an expansion of this expression + SrcSpan -- The SrcSpan of the expression + -- noSrcSpan if outermost + + | VACall + (HsExpr GhcRn) Int -- In the third argument of function f + SrcSpan -- The SrcSpan of the application (f e1 e2 e3) + +appCtxtLoc :: AppCtxt -> SrcSpan +appCtxtLoc (VAExpansion _ l) = l +appCtxtLoc (VACall _ _ l) = l + +instance Outputable AppCtxt where + ppr (VAExpansion e _) = text "VAExpansion" <+> ppr e + ppr (VACall f n _) = text "VACall" <+> int n <+> ppr f type family XPass p where XPass 'TcpRn = 'Renamed @@ -198,80 +221,92 @@ type family XEVAType p where -- Value arguments XEVAType 'TcpRn = NoExtField XEVAType _ = Scaled Type -type family XEWrap p where - XEWrap 'TcpRn = NoExtCon - XEWrap _ = HsWrapper - -mkEValArg :: SrcSpan -> LHsExpr GhcRn -> HsExprArg 'TcpRn -mkEValArg l e = EValArg { eva_loc = l, eva_arg = ValArg e - , eva_arg_ty = noExtField } +mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn +mkEValArg ctxt e = EValArg { eva_arg = ValArg e, eva_ctxt = ctxt + , eva_arg_ty = noExtField } -mkETypeArg :: SrcSpan -> LHsWcType GhcRn -> HsExprArg 'TcpRn -mkETypeArg l hs_ty = ETypeArg { eva_loc = l, eva_hs_ty = hs_ty - , eva_ty = noExtField } - -eValArgExpr :: EValArg 'TcpInst -> LHsExpr GhcRn -eValArgExpr (ValArg e) = e -eValArgExpr (ValArgQL { va_expr = e }) = e +mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn +mkETypeArg ctxt hs_ty = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty + , eva_ty = noExtField } addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst] addArgWrap wrap args | isIdHsWrapper wrap = args - | otherwise = EWrap wrap : args + | otherwise = EWrap (EHsWrap wrap) : args -splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, [HsExprArg 'TcpRn], Rebuilder) --- See Note [splitHsApps and Rebuilder] -splitHsApps e - = go e [] +splitHsApps :: HsExpr GhcRn + -> ( (HsExpr GhcRn, AppCtxt) -- Head + , [HsExprArg 'TcpRn]) -- Args +-- See Note [splitHsApps] +splitHsApps e = go e (top_ctxt 0 e) [] where - go (HsPar _ (L l fun)) args = go fun (EPar l : args) - go (HsPragE _ p (L l fun)) args = go fun (EPrag l p : args) - go (HsAppType _ (L l fun) hs_ty) args = go fun (mkETypeArg l hs_ty : args) - go (HsApp _ (L l fun) arg) args = go fun (mkEValArg l arg : args) - - go (OpApp fix arg1 (L l op) arg2) args - = (op, mkEValArg l arg1 : mkEValArg l arg2 : args, rebuild_infix fix) - - go e args = (e, args, rebuildPrefixApps) - - rebuild_infix :: Fixity -> Rebuilder - rebuild_infix fix fun args - = go fun args - where - go fun (EValArg { eva_arg = ValArg arg1, eva_loc = l } : - EValArg { eva_arg = ValArg arg2 } : args) - = rebuildPrefixApps (OpApp fix arg1 (L l fun) arg2) args - go fun (EWrap wrap : args) = go (mkHsWrap wrap fun) args - go fun args = rebuildPrefixApps fun args - -- This last case fails to rebuild a OpApp, which is sad. - -- It can happen if we have (e1 `op` e2), - -- and op :: Int -> forall a. a -> Int, and e2 :: Bool - -- Then we'll get [ e1, @Bool, e2 ] - -- Could be fixed with WpFun, but extra complexity. - -rebuildPrefixApps :: Rebuilder -rebuildPrefixApps fun args - = go fun args + top_ctxt n (HsPar _ fun) = top_lctxt n fun + 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 other_fun = VACall other_fun n noSrcSpan + + top_lctxt n (L _ fun) = top_ctxt n fun + + go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn] + -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn]) + go (HsPar _ (L l fun)) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args) + go (HsPragE _ p (L l fun)) ctxt args = go fun (set l ctxt) (EPrag ctxt p : args) + 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)) (EWrap (EExpand orig) : args) + + -- See Note [Desugar OpApp in the typechecker] + go e@(OpApp _ arg1 (L l op) arg2) _ args + = ( (op, VACall op 0 l) + , mkEValArg (VACall op 1 generatedSrcSpan) arg1 + : mkEValArg (VACall op 2 generatedSrcSpan) arg2 + : EWrap (EExpand e) + : args ) + + go e ctxt args = ((e,ctxt), args) + + set :: SrcSpan -> AppCtxt -> AppCtxt + set l (VACall f n _) = VACall f n l + set _ ctxt@(VAExpansion {}) = ctxt + + dec :: SrcSpan -> AppCtxt -> AppCtxt + dec l (VACall f n _) = VACall f (n-1) l + dec _ ctxt@(VAExpansion {}) = ctxt + +rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc +rebuildHsApps fun _ [] = fun +rebuildHsApps fun ctxt (arg : args) + = case arg of + EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' } + -> rebuildHsApps (HsApp noExtField lfun arg) ctxt' args + ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' } + -> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args + EPrag ctxt' p + -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args + EWrap (EPar ctxt') + -> rebuildHsApps (HsPar noExtField lfun) ctxt' args + EWrap (EExpand orig) + -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args + EWrap (EHsWrap wrap) + -> rebuildHsApps (mkHsWrap wrap fun) ctxt args where - go fun [] = fun - go fun (EWrap wrap : args) = go (mkHsWrap wrap fun) args - go fun (EValArg { eva_arg = ValArg arg - , eva_loc = l } : args) = go (HsApp noExtField (L l fun) arg) args - go fun (ETypeArg { eva_hs_ty = hs_ty - , eva_ty = ty - , eva_loc = l } : args) = go (HsAppType ty (L l fun) hs_ty) args - go fun (EPar l : args) = go (HsPar noExtField (L l fun)) args - go fun (EPrag l p : args) = go (HsPragE noExtField p (L l fun)) args + lfun = L (appCtxtLoc ctxt) fun isHsValArg :: HsExprArg id -> Bool isHsValArg (EValArg {}) = True isHsValArg _ = False countLeadingValArgs :: [HsExprArg id] -> Int -countLeadingValArgs (EValArg {} : args) = 1 + countLeadingValArgs args -countLeadingValArgs (EPar {} : args) = countLeadingValArgs args -countLeadingValArgs (EPrag {} : args) = countLeadingValArgs args -countLeadingValArgs _ = 0 +countLeadingValArgs [] = 0 +countLeadingValArgs (EValArg {} : args) = 1 + countLeadingValArgs args +countLeadingValArgs (EWrap {} : args) = countLeadingValArgs args +countLeadingValArgs (EPrag {} : args) = countLeadingValArgs args +countLeadingValArgs (ETypeArg {} : _) = 0 isValArg :: HsExprArg id -> Bool isValArg (EValArg {}) = True @@ -282,27 +317,22 @@ isVisibleArg (EValArg {}) = True isVisibleArg (ETypeArg {}) = True isVisibleArg _ = False -setSrcSpanFromArgs :: [HsExprArg 'TcpRn] -> TcM a -> TcM a -setSrcSpanFromArgs [] thing_inside - = thing_inside -setSrcSpanFromArgs (arg:_) thing_inside - = setSrcSpan (argFunLoc arg) thing_inside - -argFunLoc :: HsExprArg 'TcpRn -> SrcSpan -argFunLoc (EValArg { eva_loc = l }) = l -argFunLoc (ETypeArg { eva_loc = l}) = l -argFunLoc (EPrag l _) = l -argFunLoc (EPar l) = l +insideExpansion :: [HsExprArg p] -> Bool +insideExpansion args = any is_expansion args + where + is_expansion (EWrap (EExpand {})) = True + is_expansion _ = False instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where ppr (EValArg { eva_arg = arg }) = text "EValArg" <+> ppr arg ppr (EPrag _ p) = text "EPrag" <+> ppr p ppr (ETypeArg { eva_hs_ty = hs_ty }) = char '@' <> ppr hs_ty - ppr (EPar _) = text "EPar" - ppr (EWrap _) = text "EWrap" - -- ToDo: to print the wrapper properly we'll need to work harder - -- "Work harder" = replicate the ghcPass approach, but I didn't - -- think it was worth the effort to do so. + ppr (EWrap wrap) = ppr wrap + +instance Outputable EWrap where + ppr (EPar _) = text "EPar" + ppr (EHsWrap w) = text "EHsWrap" <+> ppr w + ppr (EExpand orig) = text "EExpand" <+> ppr orig instance OutputableBndrId (XPass p) => Outputable (EValArg p) where ppr (ValArg e) = ppr e @@ -315,6 +345,27 @@ pprHsExprArgTc (EValArg { eva_arg = tm, eva_arg_ty = ty }) = text "EValArg" <+> hang (ppr tm) 2 (dcolon <+> ppr ty) pprHsExprArgTc arg = ppr arg +{- Note [Desugar OpApp in the typechecker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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. +That makes it possible to typecheck something like + e1 `f` e2 +where + f :: forall a. t1 -> forall b. t2 -> t3 + +Note [Looking through HsExpanded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When creating an application chain in splitHsApps, we must deal with + HsExpanded 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`. +-} {- ********************************************************************* * * @@ -322,7 +373,7 @@ pprHsExprArgTc arg = ppr arg * * ********************************************************************* -} -tcInferAppHead :: HsExpr GhcRn +tcInferAppHead :: (HsExpr GhcRn, AppCtxt) -> [HsExprArg 'TcpRn] -> Maybe TcRhoType -- These two args are solely for tcInferRecSelId -> TcM (HsExpr GhcTc, TcSigmaType) @@ -347,8 +398,8 @@ tcInferAppHead :: HsExpr GhcRn -- cases are dealt with by splitHsApps. -- -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App -tcInferAppHead fun args mb_res_ty - = setSrcSpanFromArgs args $ +tcInferAppHead (fun,ctxt) args mb_res_ty + = setSrcSpan (appCtxtLoc ctxt) $ do { mb_tc_fun <- tcInferAppHead_maybe fun args mb_res_ty ; case mb_tc_fun of Just (fun', fun_sigma) -> return (fun', fun_sigma) @@ -367,6 +418,7 @@ tcInferAppHead_maybe fun args mb_res_ty HsRecFld _ f -> Just <$> tcInferRecSelId f args mb_res_ty ExprWithTySig _ e hs_ty -> add_head_ctxt fun args $ Just <$> tcExprWithSig e hs_ty + HsOverLit _ lit -> Just <$> tcInferOverLit lit _ -> return Nothing add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a @@ -724,6 +776,45 @@ CLong, as it should. {- ********************************************************************* * * + Overloaded literals +* * +********************************************************************* -} + +tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) +tcInferOverLit lit@(OverLit { ol_val = val + , ol_witness = HsVar _ (L loc from_name) + , ol_ext = rebindable }) + = -- Desugar "3" to (fromInteger (3 :: Integer)) + -- where fromInteger is gotten by looking up from_name, and + -- the (3 :: Integer) is returned by mkOverLit + -- Ditto the string literal "foo" to (fromString ("foo" :: String)) + do { from_id <- tcLookupId from_name + ; (wrap1, from_ty) <- topInstantiate orig (idType from_id) + + ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_doc + (1, []) from_ty + ; hs_lit <- mkOverLit val + ; co <- unifyType mb_doc (hsLitType hs_lit) (scaledThing sarg_ty) + + ; let lit_expr = L loc $ mkHsWrapCo co $ + HsLit noExtField hs_lit + from_expr = mkHsWrap (wrap2 <.> wrap1) $ + HsVar noExtField (L loc from_id) + lit' = lit { ol_witness = HsApp noExtField (L loc from_expr) lit_expr + , ol_ext = OverLitTc rebindable res_ty } + ; return (HsOverLit noExtField lit', res_ty) } + where + orig = LiteralOrigin lit + mb_doc = Just (ppr from_name) + herald = sep [ text "The function" <+> quotes (ppr from_name) + , text "is applied to"] + +tcInferOverLit lit + = pprPanic "tcInferOverLit" (ppr lit) + + +{- ********************************************************************* +* * tcInferId, tcCheckId * * ********************************************************************* -} @@ -1093,12 +1184,12 @@ addFunResCtxt fun args fun_res_ty env_ty = Outputable.empty ; return info } - where - not_fun ty -- ty is definitely not an arrow type, - -- and cannot conceivably become one - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isAlgTyCon tc - Nothing -> False + + not_fun ty -- ty is definitely not an arrow type, + -- and cannot conceivably become one + = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> isAlgTyCon tc + Nothing -> False {- Note [Splitting nested sigma types in mismatched function types] @@ -1145,9 +1236,6 @@ provided. * * ********************************************************************* -} -addLExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a -addLExprCtxt (L _ e) thing_inside = addExprCtxt e thing_inside - addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a addExprCtxt e thing_inside = case e of diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 42f0a3fddc..f250a8e82d 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -2453,7 +2453,7 @@ tcGhciStmts stmts -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $ - noLoc $ ExplicitList unitTy Nothing $ + noLoc $ ExplicitList unitTy $ map mk_item ids mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 2577de341e..69a0d2898c 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -1024,7 +1024,7 @@ tcPatToExpr name args pat = go pat go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat go1 p@(ListPat reb pats) | Nothing <- reb = do { exprs <- mapM go pats - ; return $ ExplicitList noExtField Nothing exprs } + ; return $ ExplicitList noExtField exprs } | otherwise = notInvertibleListPat p go1 (TuplePat _ pats box) = do { exprs <- mapM go pats ; return $ ExplicitTuple noExtField diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 91fac134bc..b0d970bb37 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -481,7 +481,8 @@ exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name exprCtOrigin (HsUnboundVar {}) = Shouldn'tHappenOrigin "unbound variable" exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) -exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l +exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l +exprCtOrigin (ExplicitList {}) = ListOrigin exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" @@ -501,7 +502,6 @@ exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e exprCtOrigin (HsDo {}) = DoOrigin -exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list" exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index 80f3a477dd..84e28a75e8 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -12,7 +12,8 @@ module GHC.Tc.Utils.Instantiate ( topSkolemise, - topInstantiate, instantiateSigma, + topInstantiate, + instantiateSigma, instCall, instDFunType, instStupidTheta, instTyVarsWith, newWanted, newWanteds, @@ -189,25 +190,25 @@ topSkolemise ty = return (wrap, tv_prs, ev_vars, substTy subst ty) -- substTy is a quick no-op on an empty substitution --- | Instantiate all outer type variables --- and any context. Never looks through arrows. -topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- if topInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho (that is, wrap :: ty "->" rho) --- NB: always returns a rho-type, with no top-level forall or (=>) -topInstantiate orig ty - | (tvs, theta, body) <- tcSplitSigmaTy ty +topInstantiate ::CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) +-- Instantiate outer invisible binders (both Inferred and Specified) +-- If top_instantiate ty = (wrap, inner_ty) +-- then wrap :: inner_ty "->" ty +-- NB: returns a type with no (=>), +-- and no invisible forall at the top +topInstantiate orig sigma + | (tvs, body1) <- tcSplitSomeForAllTyVars isInvisibleArgFlag sigma + , (theta, body2) <- tcSplitPhiTy body1 , not (null tvs && null theta) - = do { (_, wrap1, body1) <- instantiateSigma orig tvs theta body + = do { (_, wrap1, body3) <- instantiateSigma orig tvs theta body2 -- Loop, to account for types like -- forall a. Num a => forall b. Ord b => ... - ; (wrap2, rho) <- topInstantiate orig body1 + ; (wrap2, body4) <- topInstantiate orig body3 - ; return (wrap2 <.> wrap1, rho) } + ; return (wrap2 <.> wrap1, body4) } - | otherwise = return (idHsWrapper, ty) + | otherwise = return (idHsWrapper, sigma) instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType -> TcM ([TcTyVar], HsWrapper, TcSigmaType) @@ -658,34 +659,18 @@ cases (the rest are caught in lookupInst). newOverloadedLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc) -newOverloadedLit - lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty - | not rebindable - = do { res_ty <- expTypeToType res_ty - ; dflags <- getDynFlags - ; let platform = targetPlatform dflags - ; case shortCutLit platform val res_ty of - -- Do not generate a LitInst for rebindable syntax. - -- Reason: If we do, tcSimplify will call lookupInst, which - -- will call tcSyntaxName, which does unification, - -- which tcSimplify doesn't like - Just expr -> return (lit { ol_witness = expr - , ol_ext = OverLitTc False res_ty }) - Nothing -> newNonTrivialOverloadedLit orig lit - (mkCheckExpType res_ty) } - - | otherwise - = newNonTrivialOverloadedLit orig lit res_ty - where - orig = LiteralOrigin lit +newOverloadedLit lit res_ty + = do { mb_lit' <- tcShortCutLit lit res_ty + ; case mb_lit' of + Just lit' -> return lit' + Nothing -> newNonTrivialOverloadedLit lit res_ty } -- Does not handle things that 'shortCutLit' can handle. See also -- newOverloadedLit in GHC.Tc.Utils.Unify -newNonTrivialOverloadedLit :: CtOrigin - -> HsOverLit GhcRn +newNonTrivialOverloadedLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc) -newNonTrivialOverloadedLit orig +newNonTrivialOverloadedLit lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name) , ol_ext = rebindable }) res_ty = do { hs_lit <- mkOverLit val @@ -697,7 +682,10 @@ newNonTrivialOverloadedLit orig ; res_ty <- readExpType res_ty ; return (lit { ol_witness = witness , ol_ext = OverLitTc rebindable res_ty }) } -newNonTrivialOverloadedLit _ lit _ + where + orig = LiteralOrigin lit + +newNonTrivialOverloadedLit lit _ = pprPanic "newNonTrivialOverloadedLit" (ppr lit) ------------ diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 0c276d9e16..493602fea0 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -896,19 +896,23 @@ getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) } --- See Note [Rebindable syntax and HsExpansion]. +-- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool inGeneratedCode = tcl_in_gen_code <$> getLclEnv setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -setSrcSpan (RealSrcSpan loc _) thing_inside = - updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) - thing_inside +-- See Note [Error contexts in generated code] +-- for the tcl_in_gen_code manipulation +setSrcSpan (RealSrcSpan loc _) thing_inside + = updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) + thing_inside + setSrcSpan loc@(UnhelpfulSpan _) thing_inside - -- See Note [Rebindable syntax and HsExpansion]. - | isGeneratedSrcSpan loc = - updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside - | otherwise = thing_inside + | isGeneratedSrcSpan loc + = updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside + + | otherwise + = thing_inside addLocM :: (a -> TcM b) -> Located a -> TcM b addLocM fn (L loc a) = setSrcSpan loc $ fn a @@ -1101,7 +1105,20 @@ is applied to four arguments. See #18379 for a concrete example. This reliance on delicate inlining and Called Arity is not good. See #18202 for a more general approach. But meanwhile, these ininings seem unobjectional, and they solve the immediate -problem. -} +problem. + +Note [Error contexts in generated code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* setSrcSpan sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan, + and back to False when we get a useful SrcSpan + +* When tc_in_gen_code is True, addErrCtxt becomes a no-op. + +So typically it's better to do setSrcSpan /before/ addErrCtxt. + +See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for +more discussion of this fancy footwork. +-} getErrCtxt :: TcM [ErrCtxt] getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } @@ -1119,7 +1136,7 @@ addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] -addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m +addErrCtxtM ctxt = pushCtxt (False, ctxt) -- | Add a fixed landmark message to the error context. A landmark -- message is always sure to be reported, even if there is a lot of @@ -1133,24 +1150,25 @@ addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) -- and tidying. addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] -addLandmarkErrCtxtM ctxt m = updCtxt (push_ctxt (True, ctxt)) m - -push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, SDoc)) - -> Bool -> [ErrCtxt] -> [ErrCtxt] -push_ctxt ctxt in_gen ctxts - | in_gen = ctxts - | otherwise = ctxt : ctxts - -updCtxt :: (Bool -> [ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a -{-# INLINE updCtxt #-} -- Note [Inlining addErrCtxt] --- Helper function for the above --- The Bool is true if we are in generated code -updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt - , tcl_in_gen_code = in_gen }) -> - env { tcl_ctxt = upd in_gen ctxt }) +addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt) + +pushCtxt :: ErrCtxt -> TcM a -> TcM a +{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt] +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 +updCtxt ctxt env@(TcLclEnv { tcl_ctxt = ctxts, tcl_in_gen_code = in_gen }) + | in_gen = env + | otherwise = env { tcl_ctxt = ctxt : ctxts } popErrCtxt :: TcM a -> TcM a -popErrCtxt = updCtxt (\ _ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) +popErrCtxt = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> + env { tcl_ctxt = pop ctxt }) + where + pop [] = [] + pop (_:msgs) = msgs getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc getCtLocM origin t_or_k diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 4fb5286c70..aad5299bbf 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -20,7 +20,7 @@ module GHC.Tc.Utils.Zonk ( -- * Other HsSyn functions mkHsDictLet, mkHsApp, mkHsAppTy, mkHsCaseAlt, - shortCutLit, hsOverLitName, + tcShortCutLit, shortCutLit, hsOverLitName, conLikeResTy, -- * re-exported from TcMonad @@ -90,6 +90,7 @@ import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Types.TyThing +import GHC.Driver.Session( getDynFlags, targetPlatform ) import GHC.Data.Maybe import GHC.Data.Bag @@ -151,28 +152,75 @@ hsLitType (HsRat _ _ ty) = ty hsLitType (HsFloatPrim _ _) = floatPrimTy hsLitType (HsDoublePrim _ _) = doublePrimTy +{- ********************************************************************* +* * + Short-cuts for overloaded numeric literals +* * +********************************************************************* -} + -- Overloaded literals. Here mainly because it uses isIntTy etc +{- Note [Short cut for overloaded literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)). +But if we have a list like + [4,2,3,2,4,4,2]::[Int] +we use a lot of compile time and space generating and solving all those Num +constraints, and generating calls to fromInteger etc. Better just to cut to +the chase, and cough up an Int literal. Large collections of literals like this +sometimes appear in source files, so it's quite a worthwhile fix. + +So we try to take advantage of whatever nearby type information we have, +to short-cut the process for built-in types. We can do this in two places; + +* In the typechecker, when we are about to typecheck the literal. +* If that fails, in the desugarer, once we know the final type. +-} + +tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc)) +tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = rebindable }) exp_res_ty + | not rebindable + , Just res_ty <- checkingExpType_maybe exp_res_ty + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; case shortCutLit platform val res_ty of + Just expr -> return $ Just $ + lit { ol_witness = expr + , ol_ext = OverLitTc False res_ty } + Nothing -> return Nothing } + | otherwise + = return Nothing + shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc) -shortCutLit platform (HsIntegral int@(IL src neg i)) ty - | isIntTy ty && platformInIntRange platform i = Just (HsLit noExtField (HsInt noExtField int)) - | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i)) - | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty)) - | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty +shortCutLit platform val res_ty + = case val of + HsIntegral int_lit -> go_integral int_lit + HsFractional frac_lit -> go_fractional frac_lit + HsIsString s src -> go_string s src + where + go_integral int@(IL src neg i) + | isIntTy res_ty && platformInIntRange platform i + = Just (HsLit noExtField (HsInt noExtField int)) + | isWordTy res_ty && platformInWordRange platform i + = Just (mkLit wordDataCon (HsWordPrim src i)) + | isIntegerTy res_ty + = Just (HsLit noExtField (HsInteger src i res_ty)) + | otherwise + = go_fractional (integralFractionalLit neg i) -- The 'otherwise' case is important -- Consider (3 :: Float). Syntactically it looks like an IntLit, -- so we'll call shortCutIntLit, but of course it's a float -- This can make a big difference for programs with a lot of -- literals, compiled without -O -shortCutLit _ (HsFractional f) ty - | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) - | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) - | otherwise = Nothing + go_fractional f + | isFloatTy res_ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) + | isDoubleTy res_ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) + | otherwise = Nothing -shortCutLit _ (HsIsString src s) ty - | isStringTy ty = Just (HsLit noExtField (HsString src s)) - | otherwise = Nothing + go_string src s + | isStringTy res_ty = Just (HsLit noExtField (HsString src s)) + | otherwise = Nothing mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) @@ -881,13 +929,10 @@ zonkExpr env (HsDo ty do_or_lc (L l stmts)) new_ty <- zonkTcTypeToTypeX env ty return (HsDo new_ty do_or_lc (L l new_stmts)) -zonkExpr env (ExplicitList ty wit exprs) - = do (env1, new_wit) <- zonkWit env wit - new_ty <- zonkTcTypeToTypeX env1 ty - new_exprs <- zonkLExprs env1 exprs - return (ExplicitList new_ty new_wit new_exprs) - where zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln +zonkExpr env (ExplicitList ty exprs) + = do new_ty <- zonkTcTypeToTypeX env ty + new_exprs <- zonkLExprs env exprs + return (ExplicitList new_ty new_exprs) zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) = do { new_con_expr <- zonkExpr env con_expr diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 8a9ea3486c..2a6442cab7 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -970,7 +970,7 @@ cvtl e = wrapL (cvt e) ; return (HsLit noExtField l') } -- Note [Converting strings] | otherwise = do { xs' <- mapM cvtl xs - ; return $ ExplicitList noExtField Nothing xs' + ; return $ ExplicitList noExtField xs' } -- Infix expressions @@ -1027,7 +1027,7 @@ cvtl e = wrapL (cvt e) -- constructor names - see #14627. { s' <- vcName s ; return $ HsVar noExtField (noLoc s') } - cvt (LabelE s) = return $ HsOverLabel noExtField Nothing (fsLit s) + cvt (LabelE s) = return $ HsOverLabel noExtField (fsLit s) cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } {- | #16895 Ensure an infix expression's operator is a variable/constructor. diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index b0c83ce8b2..d29bf36d15 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -700,12 +700,11 @@ zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id -- type, we still want @isStrictId id@ to be @True@. isStrictId :: Id -> Bool isStrictId id - = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) - not (isJoinId id) && ( - (isStrictType (idType id)) || - -- Take the best of both strictnesses - old and new - (isStrUsedDmd (idDemandInfo id)) - ) + | ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) + isJoinId id = False + | otherwise = isStrictType (idType id) || + isStrUsedDmd (idDemandInfo id) + -- Take the best of both strictnesses - old and new --------------------------------- -- UNFOLDING diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 665a32a538..092ba18324 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -32,7 +32,7 @@ module GHC.Types.Id.Make ( nullAddrId, seqId, lazyId, lazyIdKey, coercionTokenId, magicDictId, coerceId, proxyHashId, noinlineId, noinlineIdName, - coerceName, + coerceName, leftSectionName, rightSectionName, -- Re-export error Ids module GHC.Core.Opt.ConstantFold @@ -53,7 +53,7 @@ import GHC.Core.Coercion import GHC.Tc.Utils.TcType as TcType import GHC.Core.Make import GHC.Core.FVs ( mkRuleInfo ) -import GHC.Core.Utils ( mkCast, mkDefaultCase ) +import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase ) import GHC.Core.Unfold.Make import GHC.Core.SimpleOpt import GHC.Types.Literal @@ -176,6 +176,8 @@ ghcPrimIds , magicDictId , coerceId , proxyHashId + , leftSectionId + , rightSectionId ] {- @@ -1427,7 +1429,8 @@ failure when trying.) nullAddrName, seqName, realWorldName, voidPrimIdName, coercionTokenName, - magicDictName, coerceName, proxyName :: Name + magicDictName, coerceName, proxyName, + leftSectionName, rightSectionName :: Name nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId @@ -1436,6 +1439,8 @@ coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionT magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId +leftSectionName = mkWiredInIdName gHC_PRIM (fsLit "leftSection") leftSectionKey leftSectionId +rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId -- Names listed in magicIds; see Note [magicIds] lazyIdName, oneShotName, noinlineIdName :: Name @@ -1513,16 +1518,84 @@ oneShotId = pcMiscPrelId oneShotName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs - ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar ] - (mkVisFunTyMany fun_ty fun_ty) + ty = mkInfForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar ] $ + mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ] $ + mkVisFunTyMany fun_ty fun_ty fun_ty = mkVisFunTyMany openAlphaTy openBetaTy [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] x' = setOneShotLambda x -- Here is the magic bit! rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar , openAlphaTyVar, openBetaTyVar , body, x'] $ - Var body `App` Var x + Var body `App` Var x' + +---------------------------------------------------------------------- +{- Note [Wired-in Ids for rebindable syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions leftSectionId, rightSectionId are +wired in here ONLY because they are use in a levity-polymorphic way +by the rebindable syntax mechanism. See GHC.Rename.Expr +Note [Handling overloaded and rebindable constructs]. + +Alas, we can't currenly give Haskell definitions for +levity-polymorphic functions. + +They have Compulsory unfoldings to so that the levity polymorphism +does not linger for long. +-} + +-- See Note [Left and right sections] in GHC.Rename.Expr +-- See Note [Wired-in Ids for rebindable syntax] +-- leftSection :: forall r1 r2 n (a:Type r1) (b:TYPE r2). +-- (a %n-> b) -> a %n-> b +-- leftSection f x = f x +-- Important that it is eta-expanded, so that (leftSection undefined `seq` ()) +-- is () and not undefined +-- Important that is is multiplicity-polymorphic (test linear/should_compile/OldList) +leftSectionId :: Id +leftSectionId = pcMiscPrelId leftSectionName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs + ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar, multiplicityTyVar1] $ + mkSpecForAllTys [openAlphaTyVar, openBetaTyVar] $ + exprType body + [f,x] = mkTemplateLocals [mkVisFunTy mult openAlphaTy openBetaTy, openAlphaTy] + + mult = mkTyVarTy multiplicityTyVar1 :: Mult + xmult = setIdMult x mult + + rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar, multiplicityTyVar1 + , openAlphaTyVar, openBetaTyVar ] body + body = mkLams [f,xmult] $ App (Var f) (Var xmult) + +-- See Note [Left and right sections] in GHC.Rename.Expr +-- See Note [Wired-in Ids for rebindable syntax] +-- 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 +-- Again, multiplicity polymorphism is important +rightSectionId :: Id +rightSectionId = pcMiscPrelId rightSectionName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs + ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar,runtimeRep3TyVar + , multiplicityTyVar1, multiplicityTyVar2 ] $ + mkSpecForAllTys [openAlphaTyVar, openBetaTyVar, openGammaTyVar ] $ + exprType body + mult1 = mkTyVarTy multiplicityTyVar1 + mult2 = mkTyVarTy multiplicityTyVar2 + + [f,x,y] = mkTemplateLocals [ mkVisFunTys [ Scaled mult1 openAlphaTy + , Scaled mult2 openBetaTy ] openGammaTy + , openAlphaTy, openBetaTy ] + xmult = setIdMult x mult1 + ymult = setIdMult y mult2 + rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar + , multiplicityTyVar1, multiplicityTyVar2 + , openAlphaTyVar, openBetaTyVar, openGammaTyVar ] body + body = mkLams [f,ymult,xmult] $ mkVarApps (Var f) [xmult,ymult] -------------------------------------------------------------------------------- magicDictId :: Id -- See Note [magicDictId magic] diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs index 397bc7ed77..4bb0b27ac8 100644 --- a/compiler/GHC/Types/Var.hs +++ b/compiler/GHC/Types/Var.hs @@ -68,8 +68,9 @@ module GHC.Types.Var ( -- * ArgFlags ArgFlag(Invisible,Required,Specified,Inferred), - isVisibleArgFlag, isInvisibleArgFlag, sameVis, AnonArgFlag(..), Specificity(..), + isVisibleArgFlag, isInvisibleArgFlag, isInferredArgFlag, + sameVis, -- * TyVar's VarBndr(..), TyCoVarBinder, TyVarBinder, InvisTVBinder, ReqTVBinder, @@ -468,12 +469,17 @@ pattern Specified = Invisible SpecifiedSpec -- | Does this 'ArgFlag' classify an argument that is written in Haskell? isVisibleArgFlag :: ArgFlag -> Bool -isVisibleArgFlag Required = True -isVisibleArgFlag _ = False +isVisibleArgFlag af = not (isInvisibleArgFlag af) -- | Does this 'ArgFlag' classify an argument that is not written in Haskell? isInvisibleArgFlag :: ArgFlag -> Bool -isInvisibleArgFlag = not . isVisibleArgFlag +isInvisibleArgFlag (Invisible {}) = True +isInvisibleArgFlag Required = False + +isInferredArgFlag :: ArgFlag -> Bool +-- More restrictive than isInvisibleArgFlag +isInferredArgFlag (Invisible InferredSpec) = True +isInferredArgFlag _ = False -- | Do these denote the same level of visibility? 'Required' -- arguments are visible, others are not. So this function diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index 0e54adb8f4..3d6500d342 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -178,12 +178,8 @@ data HsExpr p -- The renamer renames record-field selectors to HsRecFld -- The typechecker preserves HsRecFld - | HsOverLabel (XOverLabel p) - (Maybe (IdP p)) FastString + | HsOverLabel (XOverLabel p) FastString -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) - -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the - -- in-scope 'fromLabel'. - -- NB: Not in use after typechecking | HsIPVar (XIPVar p) HsIPName -- ^ Implicit parameter (not in use after typechecking) @@ -224,8 +220,8 @@ data HsExpr p -- | Operator applications: -- NB Bracketed ops such as (+) come out as Vars. - -- NB We need an expr for the operator in an OpApp/Section since - -- the typechecker may need to apply the operator to a few types. + -- NB Sadly, we need an expr for the operator in an OpApp/Section since + -- the renamer may turn a HsVar into HsRecFld or HsUnboundVar | OpApp (XOpApp p) (LHsExpr p) -- left operand @@ -343,8 +339,6 @@ data HsExpr p -- See Note [Empty lists] | ExplicitList (XExplicitList p) -- Gives type of components of list - (Maybe (SyntaxExpr p)) - -- For OverloadedLists, the fromListN witness [LHsExpr p] -- | Record construction @@ -472,7 +466,7 @@ data HsExpr p | XExpr !(XXExpr p) -- Note [Trees that Grow] extension constructor for the - -- general idea, and Note [Rebindable syntax and HsExpansion] + -- general idea, and Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr -- for an example of how we use it. -- | The AST used to hard-refer to GhcPass, which was a layer violation. For now, @@ -484,147 +478,6 @@ type family PendingTcSplice' p -- --------------------------------------------------------------------- -{- -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 - (HsExpanded - (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 -altogether. - -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 we store a RealSrcSpan in addition to a Bool in -the TcLclEnv: 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 we keep 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 - errors - --} - --- See Note [Rebindable syntax and HsExpansion] just above. -data HsExpansion a b - = HsExpanded a b - deriving Data - --- | Build a "wrapped" 'HsExpansion' out of an extension constructor, --- and the two components of the expansion: original and desugared --- expressions. --- --- See Note [Rebindable Syntax and HsExpansion] above for more details. -mkExpanded - :: (HsExpansion a b -> b) -- ^ XExpr, XCmd, ... - -> a -- ^ source expression ('GhcPs') - -> b -- ^ "desugared" expression - -- ('GhcRn') - -> b -- ^ suitably wrapped - -- 'HsExpansion' -mkExpanded xwrap a b = xwrap (HsExpanded a b) - --- | 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) - --- --------------------------------------------------------------------- - -- | A pragma, written as {-# ... #-}, that may appear within an expression. data HsPragE p = HsPragSCC (XSCC p) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 3330dbc03d..dbb86bd987 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -160,7 +160,6 @@ Library GHC.Builtin.Names GHC.Builtin.Names.TH GHC.Builtin.PrimOps - GHC.Builtin.RebindableNames GHC.Builtin.Types GHC.Builtin.Types.Literals GHC.Builtin.Types.Prim diff --git a/testsuite/tests/annotations/should_fail/annfail10.stderr b/testsuite/tests/annotations/should_fail/annfail10.stderr index fe0ff42a3e..a6e767f9e5 100644 --- a/testsuite/tests/annotations/should_fail/annfail10.stderr +++ b/testsuite/tests/annotations/should_fail/annfail10.stderr @@ -1,8 +1,8 @@ annfail10.hs:9:1: error: - • Ambiguous type variable ‘p0’ arising from an annotation - prevents the constraint ‘(Data.Data.Data p0)’ from being solved. - Probable fix: use a type annotation to specify what ‘p0’ should be. + • Ambiguous type variable ‘a0’ arising from an annotation + prevents the constraint ‘(Data.Data.Data a0)’ from being solved. + Probable fix: use a type annotation to specify what ‘a0’ should be. These potential instances exist: instance (Data.Data.Data a, Data.Data.Data b) => Data.Data.Data (Either a b) @@ -16,9 +16,9 @@ annfail10.hs:9:1: error: • In the annotation: {-# ANN f 1 #-} annfail10.hs:9:11: error: - • Ambiguous type variable ‘p0’ arising from the literal ‘1’ - prevents the constraint ‘(Num p0)’ from being solved. - Probable fix: use a type annotation to specify what ‘p0’ should be. + • Ambiguous type variable ‘a0’ arising from the literal ‘1’ + prevents the constraint ‘(Num a0)’ from being solved. + Probable fix: use a type annotation to specify what ‘a0’ should be. These potential instances exist: instance Num Integer -- Defined in ‘GHC.Num’ instance Num Double -- Defined in ‘GHC.Float’ diff --git a/testsuite/tests/ghci.debugger/Test3.hs b/testsuite/tests/ghci.debugger/Test3.hs index 3bb7bd629b..fc66e943da 100644 --- a/testsuite/tests/ghci.debugger/Test3.hs +++ b/testsuite/tests/ghci.debugger/Test3.hs @@ -1,4 +1,4 @@ mymap f [] = [] mymap f (x:xs) = f x:mymap f xs -main = mapM_ putStrLn $ mymap ('a':) ["hello","bye"] +main = mapM_ putStrLn $ mymap ('a':) ["hello","bye"] diff --git a/testsuite/tests/ghci.debugger/scripts/break017.script b/testsuite/tests/ghci.debugger/scripts/break017.script index 8873b1a0d8..d598a474d7 100644 --- a/testsuite/tests/ghci.debugger/scripts/break017.script +++ b/testsuite/tests/ghci.debugger/scripts/break017.script @@ -1,11 +1,17 @@ :l QSort.hs :set -fbreak-on-exception :trace qsort ("abc" ++ undefined) + +-- Back up to the (filter (<=a) as) call :back +:back + putStrLn "Printing 1" :print as + putStrLn "Forcing" :force as + -- this should print the exception putStrLn "Printing 2" :print as diff --git a/testsuite/tests/ghci.debugger/scripts/break017.stdout b/testsuite/tests/ghci.debugger/scripts/break017.stdout index 0de6e662ac..af22c066e6 100644 --- a/testsuite/tests/ghci.debugger/scripts/break017.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break017.stdout @@ -1,5 +1,8 @@ "Stopped in <exception thrown>, <unknown> _exception :: e = _ +Logged breakpoint at QSort.hs:6:32-34 +_result :: Char -> Bool +a :: Char Logged breakpoint at QSort.hs:6:24-38 _result :: [Char] a :: Char @@ -9,7 +12,7 @@ as = 'b' : 'c' : (_t1::[Char]) Forcing *** Exception: Prelude.undefined CallStack (from HasCallStack): - error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err + error, called at libraries/base/GHC/Err.hs:75:14 in base:GHC.Err undefined, called at <interactive>:3:17 in interactive:Ghci1 Printing 2 as = 'b' : 'c' : (_t2::[Char]) diff --git a/testsuite/tests/ghci.debugger/scripts/listCommand001.stdout b/testsuite/tests/ghci.debugger/scripts/listCommand001.stdout index 956ae6a97a..5aeb38bcd6 100644 --- a/testsuite/tests/ghci.debugger/scripts/listCommand001.stdout +++ b/testsuite/tests/ghci.debugger/scripts/listCommand001.stdout @@ -5,10 +5,10 @@ cannot list source code for map: module GHC.Base is not interpreted 1 mymap f [] = [] 2 mymap f (x:xs) = f x:mymap f xs 3 -4 main = mapM_ putStrLn $ mymap ('a':) ["hello","bye"] +4 main = mapM_ putStrLn $ mymap ('a':) ["hello","bye"] 5 3 -4 main = mapM_ putStrLn $ mymap ('a':) ["hello","bye"] +4 main = mapM_ putStrLn $ mymap ('a':) ["hello","bye"] 5 syntax: :list [<line> | <module> <line> | <identifier>] syntax: :list [<line> | <module> <line> | <identifier>] diff --git a/testsuite/tests/indexed-types/should_fail/T5439.stderr b/testsuite/tests/indexed-types/should_fail/T5439.stderr index c7f230654e..5dcce91edb 100644 --- a/testsuite/tests/indexed-types/should_fail/T5439.stderr +++ b/testsuite/tests/indexed-types/should_fail/T5439.stderr @@ -3,8 +3,7 @@ T5439.hs:82:33: error: • Couldn't match expected type: Attempt (HElemOf rs) with actual type: Attempt (HHead (HDrop n0 l0)) -> Attempt (HElemOf l0) - • Probable cause: ‘($)’ is applied to too few arguments - In the second argument of ‘($)’, namely + • In the second argument of ‘($)’, namely ‘inj $ Failure (e :: SomeException)’ In a stmt of a 'do' block: c <- complete ev $ inj $ Failure (e :: SomeException) diff --git a/testsuite/tests/indexed-types/should_fail/T7354.stderr b/testsuite/tests/indexed-types/should_fail/T7354.stderr index f8ebc7d923..e2dfbedf28 100644 --- a/testsuite/tests/indexed-types/should_fail/T7354.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7354.stderr @@ -1,13 +1,13 @@ T7354.hs:28:11: error: - • Couldn't match type ‘p’ with ‘Base t (Prim [p] p)’ - Expected: Prim [p] p -> Base t (Prim [p] p) - Actual: Prim [p] p -> p - ‘p’ is a rigid type variable bound by - the inferred type of foo :: Prim [p] p -> t + • Couldn't match type ‘a’ with ‘Base t (Prim [a] a)’ + Expected: Prim [a] a -> Base t (Prim [a] a) + Actual: Prim [a] a -> a + ‘a’ is a rigid type variable bound by + the inferred type of foo :: Prim [a] a -> t at T7354.hs:28:1-13 • In the first argument of ‘ana’, namely ‘alg’ In the expression: ana alg In an equation for ‘foo’: foo = ana alg • Relevant bindings include - foo :: Prim [p] p -> t (bound at T7354.hs:28:1) + foo :: Prim [a] a -> t (bound at T7354.hs:28:1) diff --git a/testsuite/tests/linear/should_compile/OldList.hs b/testsuite/tests/linear/should_compile/OldList.hs index e84b5bb927..d0945a7a07 100644 --- a/testsuite/tests/linear/should_compile/OldList.hs +++ b/testsuite/tests/linear/should_compile/OldList.hs @@ -32,3 +32,5 @@ sortBy cmp = [] foo ys = as (a:ys) ascending a as bs = let !x = as [a] in x : sequences bs + + diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.stdout b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.stdout index ad4352ef10..e6d8167be8 100644 --- a/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.stdout +++ b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.stdout @@ -1,4 +1,4 @@ -#x :: GHC.OverloadedLabels.IsLabel "x" t => t +#x :: GHC.OverloadedLabels.IsLabel "x" a => a "hello" "hello world" "goodbye world" diff --git a/testsuite/tests/overloadedrecflds/should_compile/T19154.hs b/testsuite/tests/overloadedrecflds/should_compile/T19154.hs new file mode 100644 index 0000000000..03deb7d44f --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T19154.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Labels where + +-- base +import Prelude +import Data.Kind + ( Type ) +import GHC.TypeLits + ( Symbol, KnownSymbol ) + +-------------------------------------------------------------------------- + +data Label (k :: Symbol) (a :: Type) = Label + +class IsLabel k a v | v -> a, v -> k where + fromLabel :: v + +-- fromLabel :: forall {k1} {k2} (k3 :: k1) (a :: k2) v. +-- IsLabel {k1} {k2} k3 a v => v + +instance KnownSymbol k => IsLabel k a (Label k a) where + fromLabel = Label @k @a + +foo :: Label k a -> () +foo _ = () + +test :: () +test = foo (#label @Bool) + diff --git a/testsuite/tests/overloadedrecflds/should_compile/all.T b/testsuite/tests/overloadedrecflds/should_compile/all.T index a043570034..b52c43a655 100644 --- a/testsuite/tests/overloadedrecflds/should_compile/all.T +++ b/testsuite/tests/overloadedrecflds/should_compile/all.T @@ -8,3 +8,5 @@ test('NFSDRF', normal, compile, ['']) test('NFSImport', [extra_files(['NFSExport.hs'])], multimod_compile, ['NFSImport NFSExport', '-v0']) test('T18999_NoFieldSelectors', normal, compile, ['']) test('T18999_FieldSelectors', normal, compile, ['']) +test('T19154', normal, compile, ['']) + diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr index 44bc014f84..f88875408d 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr @@ -1,6 +1,6 @@ overloadedlabelsfail01.hs:6:5: error: - • No instance for (IsLabel "x" t0) + • No instance for (IsLabel "x" a0) arising from the overloaded label ‘#x’ • In the expression: #x In an equation for ‘a’: a = #x diff --git a/testsuite/tests/parser/should_compile/T2245.stderr b/testsuite/tests/parser/should_compile/T2245.stderr index 8e48cfb189..ca38eec5ac 100644 --- a/testsuite/tests/parser/should_compile/T2245.stderr +++ b/testsuite/tests/parser/should_compile/T2245.stderr @@ -17,6 +17,6 @@ T2245.hs:7:27: warning: [-Wtype-defaults (in -Wall)] (Fractional b0) arising from the literal ‘1e400’ at T2245.hs:7:29-33 (Read b0) arising from a use of ‘read’ at T2245.hs:7:38-41 - • In the first argument of ‘(.)’, namely ‘(< 1e400)’ + • In the expression: (<) + In the first argument of ‘(.)’, namely ‘(< 1e400)’ In the second argument of ‘(.)’, namely ‘(< 1e400) . read’ - In the second argument of ‘($)’, namely ‘show . (< 1e400) . read’ diff --git a/testsuite/tests/parser/should_compile/T515.stderr b/testsuite/tests/parser/should_compile/T515.stderr index dde5d47b0e..580b8e722a 100644 --- a/testsuite/tests/parser/should_compile/T515.stderr +++ b/testsuite/tests/parser/should_compile/T515.stderr @@ -3,16 +3,16 @@ T515.lhs:6:3: warning: [-Wmissing-signatures (in -Wall)] Top-level binding with no type signature: a :: Integer T515.lhs:6:7: warning: [-Wtype-defaults (in -Wall)] - Defaulting the following constraint to type ‘Integer’ - Num p0 arising from the literal ‘1’ - In the expression: 1 + • Defaulting the following constraint to type ‘Integer’ + Num a0 arising from the literal ‘1’ + • In the expression: 1 In an equation for ‘a’: a = 1 T515.lhs:7:3: warning: [-Wmissing-signatures (in -Wall)] Top-level binding with no type signature: b :: Integer T515.lhs:7:7: warning: [-Wtype-defaults (in -Wall)] - Defaulting the following constraint to type ‘Integer’ - Num p0 arising from the literal ‘2’ - In the expression: 2 + • Defaulting the following constraint to type ‘Integer’ + Num a0 arising from the literal ‘2’ + • In the expression: 2 In an equation for ‘b’: b = 2 diff --git a/testsuite/tests/rebindable/T19167.hs b/testsuite/tests/rebindable/T19167.hs new file mode 100644 index 0000000000..6f7ebff33d --- /dev/null +++ b/testsuite/tests/rebindable/T19167.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE RebindableSyntax, RankNTypes, TypeApplications, OverloadedStrings, + OverloadedLists, TypeFamilies #-} + +module Bug where + +import qualified Prelude as P +import qualified GHC.Exts as P +import Data.List.NonEmpty ( NonEmpty ) + +fromInteger :: P.Integer -> forall a. P.Num a => a +fromInteger n = P.fromInteger n + +shouldBeAnInt = 3 @P.Int + +newtype RevString = RevString P.String + deriving P.Show + +instance P.IsString RevString where + fromString str = RevString (P.reverse str) + +fromString :: P.String -> forall a. P.IsString a => a +fromString str = P.fromString str + +shouldBeARevString = "hello" @RevString + +fromListN :: P.Int -> [elt] -> forall list. (P.IsList list, elt ~ P.Item list) => list +fromListN n l = P.fromListN n l + +shouldBeANonEmpty = ['x', 'y', 'z'] @(NonEmpty P.Char) diff --git a/testsuite/tests/rebindable/all.T b/testsuite/tests/rebindable/all.T index 49f77d607e..c58efa5db0 100644 --- a/testsuite/tests/rebindable/all.T +++ b/testsuite/tests/rebindable/all.T @@ -39,3 +39,4 @@ test('T11216', normal, compile, ['']) test('T11216A', normal, compile, ['']) test('T12080', normal, compile, ['']) test('T14670', expect_broken(14670), compile, ['']) +test('T19167', normal, compile, ['']) diff --git a/testsuite/tests/th/T16976.stderr b/testsuite/tests/th/T16976.stderr index 19584153c0..9cad331b51 100644 --- a/testsuite/tests/th/T16976.stderr +++ b/testsuite/tests/th/T16976.stderr @@ -1,4 +1,4 @@ -T16976.aNumber :: forall {p_0 :: *} . GHC.Num.Num p_0 => p_0 +T16976.aNumber :: forall {a_0 :: *} . GHC.Num.Num a_0 => a_0 T16976.aString :: GHC.Base.String T16976.MkT1 :: forall (s_0 :: *) . T16976.T s_0 T16976.MkT2 :: forall (s_0 :: *) . T16976.T s_0 diff --git a/testsuite/tests/typecheck/should_compile/T14590.stderr b/testsuite/tests/typecheck/should_compile/T14590.stderr index 7ecfa761f1..6f0ab068bc 100644 --- a/testsuite/tests/typecheck/should_compile/T14590.stderr +++ b/testsuite/tests/typecheck/should_compile/T14590.stderr @@ -1,8 +1,7 @@ T14590.hs:4:13: warning: [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: Int -> Int -> Int - • In the expression: x `_` - In the expression: (x `_`) y + • In the expression: (x `_`) y In an equation for ‘f1’: f1 x y = (x `_`) y • Relevant bindings include y :: Int (bound at T14590.hs:4:6) @@ -89,8 +88,7 @@ T14590.hs:4:13: warning: [-Wtyped-holes (in -Wdefault)] T14590.hs:5:13: warning: [-Wtyped-holes (in -Wdefault)] • Found hole: _a :: Int -> Int -> Int Or perhaps ‘_a’ is mis-spelled, or not in scope - • In the expression: x `_a` - In the expression: (x `_a`) y + • In the expression: (x `_a`) y In an equation for ‘f2’: f2 x y = (x `_a`) y • Relevant bindings include y :: Int (bound at T14590.hs:5:6) @@ -176,8 +174,7 @@ T14590.hs:5:13: warning: [-Wtyped-holes (in -Wdefault)] T14590.hs:6:11: warning: [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: Int -> Int -> Int - • In the expression: `_` x - In the expression: (`_` x) y + • In the expression: (`_` x) y In an equation for ‘f3’: f3 x y = (`_` x) y • Relevant bindings include y :: Int (bound at T14590.hs:6:6) @@ -264,8 +261,7 @@ T14590.hs:6:11: warning: [-Wtyped-holes (in -Wdefault)] T14590.hs:7:11: warning: [-Wtyped-holes (in -Wdefault)] • Found hole: _a :: Int -> Int -> Int Or perhaps ‘_a’ is mis-spelled, or not in scope - • In the expression: `_a` x - In the expression: (`_a` x) y + • In the expression: (`_a` x) y In an equation for ‘f4’: f4 x y = (`_a` x) y • Relevant bindings include y :: Int (bound at T14590.hs:7:6) diff --git a/testsuite/tests/typecheck/should_compile/T17775-viewpats-b.stderr b/testsuite/tests/typecheck/should_compile/T17775-viewpats-b.stderr index e631106dd0..4214016b2a 100644 --- a/testsuite/tests/typecheck/should_compile/T17775-viewpats-b.stderr +++ b/testsuite/tests/typecheck/should_compile/T17775-viewpats-b.stderr @@ -5,6 +5,6 @@ T17775-viewpats-b.hs:7:9: error: add (Eq a) to the context of the type signature for: ex2 :: forall a. a -> a -> Int -> Eq a => Bool - • In the expression: == x + • In the expression: (==) + In the expression: == x In the pattern: (== x) -> result - In an equation for ‘ex2’: ex2 x ((== x) -> result) = \ _ -> result diff --git a/testsuite/tests/typecheck/should_fail/T12921.stderr b/testsuite/tests/typecheck/should_fail/T12921.stderr index 7dd612348d..478d2f03c8 100644 --- a/testsuite/tests/typecheck/should_fail/T12921.stderr +++ b/testsuite/tests/typecheck/should_fail/T12921.stderr @@ -1,8 +1,8 @@ T12921.hs:4:1: error: - • Ambiguous type variable ‘p0’ arising from an annotation - prevents the constraint ‘(Data.Data.Data p0)’ from being solved. - Probable fix: use a type annotation to specify what ‘p0’ should be. + • Ambiguous type variable ‘a0’ arising from an annotation + prevents the constraint ‘(Data.Data.Data a0)’ from being solved. + Probable fix: use a type annotation to specify what ‘a0’ should be. These potential instances exist: instance (Data.Data.Data a, Data.Data.Data b) => Data.Data.Data (Either a b) @@ -17,10 +17,10 @@ T12921.hs:4:1: error: {-# ANN module "HLint: ignore Reduce duplication" #-} T12921.hs:4:16: error: - • Ambiguous type variable ‘p0’ arising from the literal ‘"HLint: ignore Reduce duplication"’ + • Ambiguous type variable ‘a0’ arising from the literal ‘"HLint: ignore Reduce duplication"’ prevents the constraint ‘(Data.String.IsString - p0)’ from being solved. - Probable fix: use a type annotation to specify what ‘p0’ should be. + a0)’ from being solved. + Probable fix: use a type annotation to specify what ‘a0’ should be. These potential instances exist: instance (a ~ Char) => Data.String.IsString [a] -- Defined in ‘Data.String’ diff --git a/testsuite/tests/typecheck/should_fail/T19346.hs b/testsuite/tests/typecheck/should_fail/T19346.hs new file mode 100644 index 0000000000..c2e7ea4722 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T19346.hs @@ -0,0 +1,9 @@ +module T19346 where + +data T = MkT Int + +f :: Bool -> T +f x = MkT x + +-- Produced a bad error message when compiled with +-- -fprint-typechecker-elaboration diff --git a/testsuite/tests/typecheck/should_fail/T19346.stderr b/testsuite/tests/typecheck/should_fail/T19346.stderr new file mode 100644 index 0000000000..d9cb0632e9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T19346.stderr @@ -0,0 +1,6 @@ + +T19346.hs:6:11: error: + • Couldn't match expected type ‘Int’ with actual type ‘Bool’ + • In the first argument of ‘MkT’, namely ‘x’ + In the expression: MkT x + In an equation for ‘f’: f x = MkT x diff --git a/testsuite/tests/typecheck/should_fail/T6069.stderr b/testsuite/tests/typecheck/should_fail/T6069.stderr index ffad9a9534..98b0587bbc 100644 --- a/testsuite/tests/typecheck/should_fail/T6069.stderr +++ b/testsuite/tests/typecheck/should_fail/T6069.stderr @@ -24,4 +24,4 @@ T6069.hs:15:16: error: Actual: (forall s. ST s b2) -> b2 • In the second argument of ‘(.)’, namely ‘runST’ In the first argument of ‘($)’, namely ‘(print . runST)’ - In the expression: (print . runST) $ + In the expression: ((print . runST) $) fourty_two diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 052bdd9201..07eafc65b5 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -615,3 +615,4 @@ test('TyAppPat_TooMany', normal, compile_fail, ['']) test('T12178a', normal, compile_fail, ['']) test('T18869', normal, compile_fail, ['']) test('T19142', normal, compile_fail, ['']) +test('T19346', normal, compile_fail, ['-fprint-typechecker-elaboration']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail013.stderr b/testsuite/tests/typecheck/should_fail/tcfail013.stderr index 3803d9ce95..e870b18ced 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail013.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail013.stderr @@ -4,4 +4,4 @@ tcfail013.hs:4:3: error: • In the pattern: True In an equation for ‘f’: f True = 2 • Relevant bindings include - f :: [a] -> p (bound at tcfail013.hs:3:1) + f :: [a] -> a1 (bound at tcfail013.hs:3:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail140.hs b/testsuite/tests/typecheck/should_fail/tcfail140.hs index 1fb82bb119..8a4bb7dbe5 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail140.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail140.hs @@ -17,6 +17,3 @@ t = ((\Just x -> x) :: Maybe a -> a) (Just 1) g :: Int -> Int g x y = True - - - diff --git a/testsuite/tests/typecheck/should_fail/tcfail140.stderr b/testsuite/tests/typecheck/should_fail/tcfail140.stderr index 4e1ced2fc9..8bce6238c6 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail140.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail140.stderr @@ -18,10 +18,9 @@ tcfail140.hs:12:10: error: tcfail140.hs:14:15: error: • Couldn't match expected type ‘a -> b’ with actual type ‘Int’ - • The operator ‘f’ takes two value arguments, - but its type ‘Int -> Int’ has only one - In the first argument of ‘map’, namely ‘(3 `f`)’ + • In the first argument of ‘map’, namely ‘(3 `f`)’ In the expression: map (3 `f`) xs + In an equation for ‘bot’: bot xs = map (3 `f`) xs • Relevant bindings include xs :: [a] (bound at tcfail140.hs:14:5) bot :: [a] -> [b] (bound at tcfail140.hs:14:1) |