diff options
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) |