diff options
37 files changed, 749 insertions, 168 deletions
diff --git a/compiler/GHC/Builtin/RebindableNames.hs b/compiler/GHC/Builtin/RebindableNames.hs new file mode 100644 index 0000000000..0a07224b15 --- /dev/null +++ b/compiler/GHC/Builtin/RebindableNames.hs @@ -0,0 +1,6 @@ +module GHC.Builtin.RebindableNames where + +import GHC.Data.FastString + +reboundIfSymbol :: FastString +reboundIfSymbol = fsLit "ifThenElse" diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 9f5e6a7ef2..b2c808519e 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -382,9 +382,6 @@ data HsExpr p -- For details on above see note [Api annotations] in GHC.Parser.Annotation | HsIf (XIf p) -- GhcPs: this is a Bool; False <=> do not use -- rebindable syntax - (SyntaxExpr p) -- cond function - -- NoSyntaxExpr => use the built-in 'if' - -- See Note [Rebindable if] (LHsExpr p) -- predicate (LHsExpr p) -- then part (LHsExpr p) -- else part @@ -557,8 +554,10 @@ data HsExpr p -- Expressions annotated with pragmas, written as {-# ... #-} | HsPragE (XPragE p) (HsPragE p) (LHsExpr p) - | XExpr !(XXExpr p) -- Note [Trees that Grow] extension constructor - + | XExpr !(XXExpr p) + -- Note [Trees that Grow] extension constructor for the + -- general idea, and Note [Rebindable syntax and HsExpansion] + -- for an example of how we use it. -- | Extra data fields for a 'RecordCon', added by the type checker data RecordConTc = RecordConTc @@ -624,9 +623,7 @@ type instance XExplicitSum GhcTc = [Type] type instance XCase (GhcPass _) = NoExtField -type instance XIf GhcPs = Bool -- True <=> might use rebindable syntax -type instance XIf GhcRn = NoExtField -type instance XIf GhcTc = NoExtField +type instance XIf (GhcPass _) = NoExtField type instance XMultiIf GhcPs = NoExtField type instance XMultiIf GhcRn = NoExtField @@ -674,8 +671,155 @@ type instance XBinTick (GhcPass _) = NoExtField type instance XPragE (GhcPass _) = NoExtField type instance XXExpr GhcPs = NoExtCon -type instance XXExpr GhcRn = NoExtCon -type instance XXExpr GhcTc = HsWrap HsExpr + +-- See Note [Rebindable syntax and HsExpansion] below +type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) + (HsExpr GhcRn) +type instance XXExpr GhcTc = XXExprGhcTc + +data XXExprGhcTc + = WrapExpr {-# UNPACK #-} !(HsWrap HsExpr) + | ExpansionExpr {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc)) + + +{- +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) -- --------------------------------------------------------------------- @@ -1020,7 +1164,7 @@ ppr_expr (HsCase _ expr matches) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], nest 2 (pprMatches matches) ] -ppr_expr (HsIf _ _ e1 e2 e3) +ppr_expr (HsIf _ e1 e2 e3) = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], nest 4 (ppr e2), text "else", @@ -1092,21 +1236,25 @@ ppr_expr (HsRecFld _ f) = ppr f ppr_expr (XExpr x) = case ghcPass @p of #if __GLASGOW_HASKELL__ < 811 GhcPs -> ppr x - GhcRn -> ppr x #endif + GhcRn -> ppr x GhcTc -> case x of - HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e - else pprExpr e) + WrapExpr (HsWrap co_fn e) -> pprHsWrapper co_fn + (\parens -> if parens then pprExpr e else pprExpr e) + ExpansionExpr e -> ppr e -- e is an HsExpansion, we print the original + -- expression (LHsExpr GhcPs), not the + -- desugared one (LHsExpr GhcT). ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c)) ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f) ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ) -ppr_infix_expr (XExpr x) - | GhcTc <- ghcPass @p - , HsWrap _ e <- x - = ppr_infix_expr e +ppr_infix_expr (XExpr x) = case (ghcPass @p, x) of + (GhcPs, _) -> Nothing + (GhcRn, HsExpanded a _) -> ppr_infix_expr a + (GhcTc, WrapExpr (HsWrap _ e)) -> ppr_infix_expr e + (GhcTc, ExpansionExpr (HsExpanded a _)) -> ppr_infix_expr a ppr_infix_expr _ = Nothing ppr_apps :: (OutputableBndrId p) @@ -1207,9 +1355,11 @@ hsExprNeedsParens p = go go (HsRecFld{}) = False go (XExpr x) | GhcTc <- ghcPass @p - , HsWrap _ e <- x - = go e - + = case x of + WrapExpr (HsWrap _ e) -> go e + ExpansionExpr (HsExpanded a _) -> hsExprNeedsParens p a + | GhcRn <- ghcPass @p + = case x of HsExpanded a _ -> hsExprNeedsParens p a | otherwise = True @@ -1241,8 +1391,11 @@ isAtomicHsExpr (HsUnboundVar {}) = True isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) isAtomicHsExpr (HsRecFld{}) = True isAtomicHsExpr (XExpr x) - | GhcTc <- ghcPass @p - , HsWrap _ e <- x = isAtomicHsExpr e + | GhcTc <- ghcPass @p = case x of + WrapExpr (HsWrap _ e) -> isAtomicHsExpr e + ExpansionExpr (HsExpanded a _) -> isAtomicHsExpr a + | GhcRn <- ghcPass @p = case x of + HsExpanded a _ -> isAtomicHsExpr a isAtomicHsExpr _ = False instance Outputable (HsPragE (GhcPass p)) where diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 87ded0d22d..d46f9d7986 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -468,4 +468,7 @@ deriving instance Eq (IE GhcPs) deriving instance Eq (IE GhcRn) deriving instance Eq (IE GhcTc) + -- --------------------------------------------------------------------- + +deriving instance Data XXExprGhcTc diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 626a771be7..3e37e7b388 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -33,7 +33,8 @@ just attach noSrcSpan to everything. module GHC.Hs.Utils( -- * Terms - mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt, + mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith, + mkHsAppType, mkHsAppTypes, mkHsCaseAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, @@ -189,7 +190,25 @@ mkLocatedList [] = noLoc [] mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2) +mkHsApp = mkHsAppWith addCLoc + +mkHsAppWith + :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)) + -> LHsExpr (GhcPass id) + -> LHsExpr (GhcPass id) + -> LHsExpr (GhcPass id) +mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noExtField e1 e2) + +mkHsApps + :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) +mkHsApps = mkHsAppsWith addCLoc + +mkHsAppsWith + :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)) + -> LHsExpr (GhcPass id) + -> [LHsExpr (GhcPass id)] + -> LHsExpr (GhcPass id) +mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated) mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct) @@ -291,8 +310,7 @@ mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) -- restricted to GhcPs because other phases might need a SyntaxExpr mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsIf c a b = HsIf True {- this might use rebindable syntax -} noSyntaxExpr c a b - -- see Note [Rebindable if] in "GHC.Hs.Expr" +mkHsIf c a b = HsIf noExtField c a b -- restricted to GhcPs because other phases might need a SyntaxExpr mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs @@ -508,9 +526,8 @@ nlHsPar e = noLoc (HsPar noExtField e) -- nlHsIf should generate if-expressions which are NOT subject to -- RebindableSyntax, so the first field of HsIf is False. (#12080) --- See Note [Rebindable if] in "GHC.Hs.Expr" nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -nlHsIf cond true false = noLoc (HsIf False noSyntaxExpr cond true false) +nlHsIf cond true false = noLoc (HsIf noExtField cond true false) nlHsCase expr matches = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches)) @@ -690,9 +707,9 @@ mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) -- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr" mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc mkHsWrap co_fn e | isIdHsWrapper co_fn = e -mkHsWrap co_fn (XExpr (HsWrap co_fn' e)) = mkHsWrap (co_fn <.> co_fn') e -mkHsWrap co_fn (HsPar x (L l e)) = HsPar x (L l (mkHsWrap co_fn e)) -mkHsWrap co_fn e = XExpr (HsWrap co_fn e) +mkHsWrap co_fn (XExpr (WrapExpr (HsWrap co_fn' e))) = mkHsWrap (co_fn <.> co_fn') e +mkHsWrap co_fn (HsPar x (L l e)) = HsPar x (L l (mkHsWrap co_fn e)) +mkHsWrap co_fn e = XExpr (WrapExpr $ HsWrap co_fn e) mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b -> HsExpr GhcTc -> HsExpr GhcTc diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 7451d0113d..edd67e5b17 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -552,8 +552,8 @@ addTickHsExpr (HsCase x e mgs) = (addTickLHsExpr e) -- not an EvalInner; e might not necessarily -- be evaluated. (addTickMatchGroup False mgs) -addTickHsExpr (HsIf x cnd e1 e2 e3) = - liftM3 (HsIf x cnd) +addTickHsExpr (HsIf x e1 e2 e3) = + liftM3 (HsIf x) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsExprOptAlt True e2) (addTickLHsExprOptAlt True e3) @@ -629,10 +629,12 @@ addTickHsExpr (HsProc x pat cmdtop) = liftM2 (HsProc x) (addTickLPat pat) (liftL (addTickHsCmdTop) cmdtop) -addTickHsExpr (XExpr (HsWrap w e)) = - liftM XExpr $ - liftM (HsWrap w) +addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) = + liftM (XExpr . WrapExpr . HsWrap w) $ (addTickHsExpr e) -- Explicitly no tick on inside +addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) = + liftM (XExpr . ExpansionExpr . HsExpanded a) $ + (addTickHsExpr b) -- Others should never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 696cebe565..7ac72bad55 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -276,12 +276,12 @@ dsExpr (HsLit _ lit) dsExpr (HsOverLit _ lit) = do { warnAboutOverflowedOverLit lit ; dsOverLit lit } - -dsExpr hswrap@(XExpr (HsWrap co_fn e)) +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 HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc) - XExpr (HsWrap _ _) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap) + XExpr (WrapExpr (HsWrap _ _)) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap) HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap) _ -> addTyCsDs FromSource (hsWrapDictBinders co_fn) $ dsExpr e @@ -474,13 +474,11 @@ dsExpr (HsDo _ ctx@GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts dsExpr (HsDo _ ctx@MDoExpr{} (L _ stmts)) = dsDo ctx stmts dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts -dsExpr (HsIf _ fun guard_expr then_expr else_expr) +dsExpr (HsIf _ guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr ; b1 <- dsLExpr then_expr ; b2 <- dsLExpr else_expr - ; case fun of -- See Note [Rebindable if] in "GHC.Hs.Expr" - (SyntaxExprTc {}) -> dsSyntaxExpr fun [pred, b1, b2] - NoSyntaxExprTc -> return $ mkIfThenElse pred b1 b2 } + ; return $ mkIfThenElse pred b1 b2 } dsExpr (HsMultiIf res_ty alts) | null alts diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 6bff5e826f..5dc7328879 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -1056,7 +1056,10 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp e (HsPar _ (L _ e')) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers - exp (XExpr (HsWrap h e)) (XExpr (HsWrap h' e')) = wrap h h' && exp e e' + exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap h' e'))) = + wrap h h' && exp e e' + exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) = + exp b b' exp (HsVar _ i) (HsVar _ i') = i == i' exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c' -- the instance for IPName derives using the id, so this works if the @@ -1084,7 +1087,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) = eq_list tup_arg es1 es2 exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e' - exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') = + exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = lexp e e' && lexp e1 e1' && lexp e2 e2' -- Enhancement: could implement equality for more expressions diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index cdea4a6ff5..bbe56af5b7 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1474,11 +1474,11 @@ repE (HsCase _ e (MG { mg_alts = (L _ ms) })) ; ms2 <- mapM repMatchTup ms ; core_ms2 <- coreListM matchTyConName ms2 ; repCaseE arg core_ms2 } -repE (HsIf _ _ x y z) = do - a <- repLE x - b <- repLE y - c <- repLE z - repCond a b c +repE (HsIf _ x y z) = do + a <- repLE x + b <- repLE y + c <- repLE z + repCond a b c repE (HsMultiIf _ alts) = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') @@ -1569,7 +1569,7 @@ repE (HsUnboundVar _ uv) = do occ <- occNameLit uv sname <- repNameS occ repUnboundVar sname - +repE (XExpr (HsExpanded _ b)) = repE b repE e@(HsPragE _ HsPragCore {} _) = notHandled "Core annotations" (ppr e) repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e) repE e@(HsPragE _ HsPragTick {} _) = notHandled "Tick Pragma" (ppr e) diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 7c9c37efe2..6325b722e9 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -758,14 +758,14 @@ instance HiePass p => HasType (LHsExpr (GhcPass p)) where -- performance before marking more things as 'True'. skipDesugaring :: HsExpr GhcTc -> Bool skipDesugaring e = case e of - HsVar{} -> False - HsUnboundVar{} -> False - HsConLikeOut{} -> False - HsRecFld{} -> False - HsOverLabel{} -> False - HsIPVar{} -> False - XExpr (HsWrap{}) -> False - _ -> True + HsVar{} -> False + HsUnboundVar{} -> False + HsConLikeOut{} -> False + HsRecFld{} -> False + HsOverLabel{} -> False + HsIPVar{} -> False + XExpr (WrapExpr {}) -> False + _ -> True data HiePassEv p where HieRn :: HiePassEv 'Renamed @@ -1099,7 +1099,7 @@ instance HiePass p => ToHie (LHsExpr (GhcPass p)) where [ toHie expr , toHie matches ] - HsIf _ _ a b c -> + HsIf _ a b c -> [ toHie a , toHie b , toHie c @@ -1166,10 +1166,14 @@ instance HiePass p => ToHie (LHsExpr (GhcPass p)) where ] XExpr x | GhcTc <- ghcPass @p - , HsWrap w a <- x + , WrapExpr (HsWrap w a) <- x -> [ toHie $ L mspan a , toHie (L mspan w) ] + | GhcTc <- ghcPass @p + , ExpansionExpr (HsExpanded _ b) <- x + -> [ toHie (L mspan b) + ] | otherwise -> [] instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index e425fd9457..2b0a2e5ae9 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -31,7 +31,7 @@ module GHC.Rename.Env ( -- Rebindable Syntax lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames, - lookupIfThenElse, + lookupIfThenElse, lookupReboundIf, -- QualifiedDo lookupQualifiedDoExpr, lookupQualifiedDo, @@ -58,6 +58,7 @@ import GHC.Driver.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Parser.PostProcess ( filterCTuple, setRdrNameSpace ) +import GHC.Builtin.RebindableNames import GHC.Builtin.Types import GHC.Types.Name import GHC.Types.Name.Set @@ -1770,6 +1771,32 @@ lookupQualifiedDoName ctxt std_name Nothing -> lookupSyntaxName 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 diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 2bfba1fb7f..35dfb6b282 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -322,14 +322,21 @@ rnExpr (ExprWithTySig _ expr pty) ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ rnLExpr expr ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) } - -rnExpr (HsIf might_use_rebindable_syntax _ p b1 b2) +rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLExpr b1 ; (b2', fvB2) <- rnLExpr b2 - ; (mb_ite, fvITE) <- lookupIfThenElse might_use_rebindable_syntax - ; return (HsIf noExtField mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } - + ; 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]) + } rnExpr (HsMultiIf x alts) = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts -- ; return (HsMultiIf ty alts', fvs) } @@ -2224,3 +2231,26 @@ getMonadFailOp ctxt mkSyntaxExpr failAfterFromStringExpr return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs) | otherwise = lookupQualifiedDo ctxt failMName + +-- Rebinding 'if's to 'ifThenElse' applications. +-- +-- 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) diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 48a663952a..e49ff87db2 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -111,6 +111,8 @@ rnBracket e br_body False -> do { traceRn "Renaming untyped TH bracket" empty ; ps_var <- newMutVar [] ; (body', fvs_e) <- + -- See Note [Rebindable syntax and Template Haskell] + unsetXOptM LangExt.RebindableSyntax $ setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ rn_bracket cur_stage br_body ; pendings <- readMutVar ps_var @@ -492,6 +494,67 @@ 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. + +One might expect that with {-# LANGUAGE RebindableSyntax #-} at the top of a +module, any 'if' expression would end up being turned into a call to whatever +'ifThenElse' function is in scope, regardless of whether the said if expression +appears in "normal" Haskell code or in a TH quote. This however comes with its +problems. Consider the following code: + + {-# LANGUAGE TemplateHaskell, RebindableSyntax #-} + + module X where + + import Prelude ( Monad(..), Bool(..), print, ($) ) + import Language.Haskell.TH.Syntax + + $( do stuff <- [| if True then 10 else 15 |] + runIO $ print stuff + return [] ) + +If we apply the RS rules, then GHC would complain about not having suitable +fromInteger/ifThenElse functions in scope. But this quote is just a bit of +Haskell syntax that has yet to be used, or, to put it differently, placed +(spliced) in some context where the said functions might be available. More +generally, untyped TH quotes are meant to work with yet-unbound identifiers. +This tends to show that untyped TH and Rebindable Syntax overall don't play +well together. Users still have the option to splice "normal" if expressions +into modules where RS is enabled, to turn them into applications of +an 'ifThenElse' function of their choice. + +Typed TH (TTH) quotes, on the other hand, come with different constraints. They +don't quite have this "delayed" nature: we typecheck them while processing +them, and TTH users expect RS to Just Work in their quotes, exactly like it does +outside of the quotes. There, we do not have to accept unbound identifiers and +we can apply the RS rules both in the typechecking and desugaring of the quotes +without triggering surprising/bad behaviour for users. For instance, the +following code is expected to be rejected (because of the lack of suitable +'fromInteger'/'ifThenElse' functions in scope): + + {-# LANGUAGE TemplateHaskell, RebindableSyntax #-} + + module X where + + import Prelude ( Monad(..), Bool(..), print, ($) ) + import Language.Haskell.TH.Syntax + + $$( do stuff <- [|| if True then 10 else 15 ||] + runIO $ print stuff + return [] ) + +The conclusion is that even if RS is enabled for a given module, GHC disables it +when processing untyped TH quotes from that module, to avoid the aforementioned +problems, but keeps it on while processing typed TH quotes. + +This note and approach originated in #18102. + +-} + {- Note [Delaying modFinalizers in untyped splices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index eaf3a3db0c..d5ecbcbe45 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -123,12 +123,20 @@ tcPolyExpr expr res_ty ; tcPolyExprNC expr res_ty } tcPolyExprNC (L loc expr) res_ty - = setSrcSpan loc $ + = 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') } + 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 (L l e) m + else setSrcSpan l m + --------------- tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType) -- Used by tcRnExpr to implement GHCi :type @@ -188,7 +196,7 @@ tcLExpr, tcLExprNC -> TcM (LHsExpr GhcTc) tcLExpr expr res_ty - = addExprCtxt expr (tcLExprNC expr res_ty) + = setSrcSpan (getLoc expr) $ addExprCtxt expr (tcLExprNC expr res_ty) tcLExprNC (L loc expr) res_ty = setSrcSpan loc $ @@ -589,26 +597,15 @@ tcExpr (HsCase x scrut matches) res_ty match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr (HsIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' +tcExpr (HsIf x pred b1 b2) res_ty = do { pred' <- tcLExpr pred (mkCheckExpType boolTy) ; res_ty <- tauifyExpType res_ty -- Just like Note [Case branches must never infer a non-tau type] -- in GHC.Tc.Gen.Match (See #10619) - ; (u1,b1') <- tcCollectingUsage $ tcLExpr b1 res_ty ; (u2,b2') <- tcCollectingUsage $ tcLExpr b2 res_ty ; tcEmitBindingUsage (supUE u1 u2) - ; return (HsIf x NoSyntaxExprTc pred' b1' b2') } - -tcExpr (HsIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty - = do { ((pred', b1', b2'), fun') - <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $ - \ [pred_ty, b1_ty, b2_ty] [pred_mult, b1_mult, b2_mult] -> - do { pred' <- tcScalingUsage pred_mult $ tcCheckPolyExpr pred pred_ty - ; b1' <- tcScalingUsage b1_mult $ tcCheckPolyExpr b1 b1_ty - ; b2' <- tcScalingUsage b2_mult $ tcCheckPolyExpr b2 b2_ty - ; return (pred', b1', b2') } - ; return (HsIf x fun' pred' b1' b2') } + ; return (HsIf x pred' b1' b2') } tcExpr (HsMultiIf _ alts) res_ty = do { res_ty <- if isSingleton alts @@ -1063,6 +1060,19 @@ 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 * * ************************************************************************ diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index f99f99d1a5..611d89954b 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -754,7 +754,8 @@ data TcLclEnv -- Changes as we move inside an expression = TcLclEnv { tcl_loc :: RealSrcSpan, -- Source span tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top - tcl_tclvl :: TcLevel, -- Birthplace for new unification variables + tcl_in_gen_code :: Bool, -- See Note [Rebindable syntax and HsExpansion] + tcl_tclvl :: TcLevel, tcl_th_ctxt :: ThStage, -- Template Haskell context tcl_th_bndrs :: ThBindEnv, -- and binder info diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 7dfa5ffd65..f89841de92 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -501,7 +501,6 @@ exprCtOrigin (SectionR _ _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches -exprCtOrigin (HsIf _ (SyntaxExprRn syn) _ _ _) = exprCtOrigin syn exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e @@ -520,6 +519,7 @@ exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e +exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index c65879a8b4..18cdfdf935 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -59,7 +59,7 @@ module GHC.Tc.Utils.Monad( addDependentFiles, -- * Error management - getSrcSpanM, setSrcSpan, addLocM, + getSrcSpanM, setSrcSpan, addLocM, inGeneratedCode, wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_, getErrsVar, setErrsVar, addErr, @@ -82,7 +82,7 @@ module GHC.Tc.Utils.Monad( -- * Context management for the type checker getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, - addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM, + addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, -- * Error message generation (type checker) addErrTc, @@ -341,7 +341,9 @@ initTcWithGbl hsc_env gbl_env loc do_this ; usage_var <- newIORef zeroUE ; let lcl_env = TcLclEnv { tcl_errs = errs_var, - tcl_loc = loc, -- Should be over-ridden very soon! + tcl_loc = loc, + -- tcl_loc should be over-ridden very soon! + tcl_in_gen_code = False, tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage, @@ -866,11 +868,19 @@ getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) } +-- See Note [Rebindable syntax and HsExpansion]. +inGeneratedCode :: TcRn Bool +inGeneratedCode = tcl_in_gen_code <$> getLclEnv + setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -setSrcSpan (RealSrcSpan real_loc _) thing_inside - = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside --- Don't overwrite useful info with useless: -setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside +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 addLocM :: (a -> TcM b) -> Located a -> TcM b addLocM fn (L loc a) = setSrcSpan loc $ fn a @@ -1037,40 +1047,71 @@ failIfErrsM = ifErrsM failM (return ()) ************************************************************************ -} +{- Note [Inlining addErrCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You will notice a bunch of INLINE pragamas on addErrCtxt and friends. +The reason is to promote better eta-expansion in client modules. +Consider + \e s. addErrCtxt c (tc_foo x) e s +It looks as if tc_foo is applied to only two arguments, but if we +inline addErrCtxt it'll turn into something more like + \e s. tc_foo x (munge c e) s +This is much better because Called Arity analysis can see that tc_foo +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. -} + getErrCtxt :: TcM [ErrCtxt] getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a +{-# INLINE setErrCtxt #-} -- Note [Inlining addErrCtxt] setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) -- | Add a fixed message to the error context. This message should not -- do any tidying. addErrCtxt :: MsgDoc -> TcM a -> TcM a +{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a -addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts) +{-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] +addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m -- | 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 -- context. It also doesn't count toward the maximum number of contexts -- reported. addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a +{-# INLINE addLandmarkErrCtxt #-} -- Note [Inlining addErrCtxt] addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations -- and tidying. addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a -addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts) +{-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] +addLandmarkErrCtxtM ctxt m = updCtxt (push_ctxt (True, ctxt)) m + +push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) + -> 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 -updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a -updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> - env { tcl_ctxt = upd ctxt }) +-- 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 }) popErrCtxt :: TcM a -> TcM a -popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) +popErrCtxt = updCtxt (\ _ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) 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 c23d1a9e21..63a46dda14 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -825,12 +825,11 @@ zonkExpr env (HsCase x expr ms) new_ms <- zonkMatchGroup env zonkLExpr ms return (HsCase x new_expr new_ms) -zonkExpr env (HsIf x fun e1 e2 e3) - = do (env1, new_fun) <- zonkSyntaxExpr env fun - new_e1 <- zonkLExpr env1 e1 - new_e2 <- zonkLExpr env1 e2 - new_e3 <- zonkLExpr env1 e3 - return (HsIf x new_fun new_e1 new_e2 new_e3) +zonkExpr env (HsIf x e1 e2 e3) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + new_e3 <- zonkLExpr env e3 + return (HsIf x new_e1 new_e2 new_e3) zonkExpr env (HsMultiIf ty alts) = do { alts' <- mapM (wrapLocM zonk_alt) alts @@ -907,10 +906,13 @@ zonkExpr env (HsProc x pat body) zonkExpr env (HsStatic fvs expr) = HsStatic fvs <$> zonkLExpr env expr -zonkExpr env (XExpr (HsWrap co_fn expr)) +zonkExpr env (XExpr (WrapExpr (HsWrap co_fn expr))) = do (env1, new_co_fn) <- zonkCoFn env co_fn new_expr <- zonkExpr env1 expr - return (XExpr (HsWrap new_co_fn new_expr)) + return (XExpr (WrapExpr (HsWrap new_co_fn new_expr))) + +zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b))) + = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b zonkExpr _ e@(HsUnboundVar {}) = return e diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs index 71b74c00d5..00bf00ac2c 100644 --- a/compiler/GHC/Types/SrcLoc.hs +++ b/compiler/GHC/Types/SrcLoc.hs @@ -39,10 +39,11 @@ module GHC.Types.SrcLoc ( -- * SrcSpan RealSrcSpan, -- Abstract SrcSpan(..), + UnhelpfulSpanReason(..), -- ** Constructing SrcSpan mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, - noSrcSpan, + noSrcSpan, generatedSrcSpan, isGeneratedSrcSpan, wiredInSrcSpan, -- Something wired into the compiler interactiveSrcSpan, srcLocSpan, realSrcLocSpan, @@ -53,7 +54,8 @@ module GHC.Types.SrcLoc ( srcSpanStart, srcSpanEnd, realSrcSpanStart, realSrcSpanEnd, srcSpanFileName_maybe, - pprUserRealSpan, + pprUserRealSpan, pprUnhelpfulSpanReason, + unhelpfulSpanFS, -- ** Unsafely deconstructing SrcSpan -- These are dubious exports, because they crash on some inputs @@ -302,12 +304,19 @@ data BufSpan = -- or a human-readable description of a location. data SrcSpan = RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos] - | UnhelpfulSpan !FastString -- Just a general indication - -- also used to indicate an empty span + | UnhelpfulSpan !UnhelpfulSpanReason deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we -- derive Show for Token +data UnhelpfulSpanReason + = UnhelpfulNoLocationInfo + | UnhelpfulWiredIn + | UnhelpfulInteractive + | UnhelpfulGenerated + | UnhelpfulOther !FastString + deriving (Eq, Show) + {- Note [Why Maybe BufPos] ~~~~~~~~~~~~~~~~~~~~~~~~~~ In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan). @@ -344,18 +353,23 @@ instance NFData SrcSpan where rnf x = x `seq` () -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty -noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan -noSrcSpan = UnhelpfulSpan (fsLit "<no location info>") -wiredInSrcSpan = UnhelpfulSpan (fsLit "<wired into compiler>") -interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>") +noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan +noSrcSpan = UnhelpfulSpan UnhelpfulNoLocationInfo +wiredInSrcSpan = UnhelpfulSpan UnhelpfulWiredIn +interactiveSrcSpan = UnhelpfulSpan UnhelpfulInteractive +generatedSrcSpan = UnhelpfulSpan UnhelpfulGenerated + +isGeneratedSrcSpan :: SrcSpan -> Bool +isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True +isGeneratedSrcSpan _ = False -- | Create a "bad" 'SrcSpan' that has not location information mkGeneralSrcSpan :: FastString -> SrcSpan -mkGeneralSrcSpan = UnhelpfulSpan +mkGeneralSrcSpan = UnhelpfulSpan . UnhelpfulOther -- | Create a 'SrcSpan' corresponding to a single point srcLocSpan :: SrcLoc -> SrcSpan -srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str +srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str) srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb) realSrcLocSpan :: RealSrcLoc -> RealSrcSpan @@ -383,8 +397,8 @@ isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) -- | Create a 'SrcSpan' between two points in a file mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan -mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str -mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str +mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan (UnhelpfulOther str) +mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str) mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) = RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2) @@ -396,7 +410,8 @@ combineSrcSpans l (UnhelpfulSpan _) = l combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) | srcSpanFile span1 == srcSpanFile span2 = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) - | otherwise = UnhelpfulSpan (fsLit "<combineSrcSpans: files differ>") + | otherwise = UnhelpfulSpan $ + UnhelpfulOther (fsLit "<combineSrcSpans: files differ>") -- | Combines two 'SrcSpan' into one that spans at least all the characters -- within both spans. Assumes the "file" part is the same in both inputs @@ -488,12 +503,12 @@ srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanStart :: SrcSpan -> SrcLoc -srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanStart (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanEnd :: SrcSpan -> SrcLoc -srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanEnd (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) realSrcSpanStart :: RealSrcSpan -> RealSrcLoc @@ -559,6 +574,9 @@ instance Outputable RealSrcSpan where instance Outputable SrcSpan where ppr span = pprUserSpan True span +instance Outputable UnhelpfulSpanReason where + ppr = pprUnhelpfulSpanReason + -- I don't know why there is this style-based difference -- = getPprStyle $ \ sty -> -- if userStyle sty || debugStyle sty then @@ -568,8 +586,19 @@ instance Outputable SrcSpan where -- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" -- RealSrcSpan s -> ppr s +unhelpfulSpanFS :: UnhelpfulSpanReason -> FastString +unhelpfulSpanFS r = case r of + UnhelpfulOther s -> s + UnhelpfulNoLocationInfo -> fsLit "<no location info>" + UnhelpfulWiredIn -> fsLit "<wired into compiler>" + UnhelpfulInteractive -> fsLit "<interactive>" + UnhelpfulGenerated -> fsLit "<generated>" + +pprUnhelpfulSpanReason :: UnhelpfulSpanReason -> SDoc +pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r) + pprUserSpan :: Bool -> SrcSpan -> SDoc -pprUserSpan _ (UnhelpfulSpan s) = ftext s +pprUserSpan _ (UnhelpfulSpan r) = pprUnhelpfulSpanReason r pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index 5bcc98cff4..d73939c53c 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -1448,6 +1448,23 @@ instance Binary BufSpan where end <- get bh return (BufSpan start end) +instance Binary UnhelpfulSpanReason where + put_ bh r = case r of + UnhelpfulNoLocationInfo -> putByte bh 0 + UnhelpfulWiredIn -> putByte bh 1 + UnhelpfulInteractive -> putByte bh 2 + UnhelpfulGenerated -> putByte bh 3 + UnhelpfulOther fs -> putByte bh 4 >> put_ bh fs + + get bh = do + h <- getByte bh + case h of + 0 -> return UnhelpfulNoLocationInfo + 1 -> return UnhelpfulWiredIn + 2 -> return UnhelpfulInteractive + 3 -> return UnhelpfulGenerated + _ -> UnhelpfulOther <$> get bh + instance Binary SrcSpan where put_ bh (RealSrcSpan ss sb) = do putByte bh 0 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index ce887f6a85..dff5244f08 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -398,6 +398,7 @@ Library GHC.Builtin.Names GHC.Core.Opt.ConstantFold GHC.Builtin.PrimOps + GHC.Builtin.RebindableNames GHC.Builtin.Types.Prim GHC.Builtin.Types GHC.Types.CostCentre diff --git a/docs/users_guide/exts/template_haskell.rst b/docs/users_guide/exts/template_haskell.rst index a97f9a8f6b..f1319b904e 100644 --- a/docs/users_guide/exts/template_haskell.rst +++ b/docs/users_guide/exts/template_haskell.rst @@ -542,6 +542,30 @@ Run :file:`main` and here is your output: $ ./main Hello +.. _th-rs: + +Template Haskell quotes and Rebindable Syntax +--------------------------------------------- + +Rebindable syntax does not play well with untyped TH quotes: +applying the rebindable syntax rules would go against the lax +nature of untyped quotes that are accepted even in the presence of +unbound identifiers (see :ghc-ticket:`18102`). Applying the rebindable syntax +rules to them would force the code that defines the said quotes to have all +the necessary functions (e.g ``ifThenElse`` or ``fromInteger``) in scope, +instead of delaying the resolution of those symbols to the code that splices +the quoted Haskell syntax, as is usually done with untyped TH. For this reason, +even if a module has untyped TH quotes with ``RebindableSyntax`` enabled, GHC +turns off rebindable syntax while processing the quotes. The code that splices +the quotes is however free to turn on ``RebindableSyntax`` to have the usual +rules applied to the resulting code. + +Typed TH quotes on the other hand are perfectly compatible with the eager +application of rebindable syntax rules, and GHC will therefore process any +such quotes according to the rebindable syntax rules whenever the +``RebindableSyntax`` extension is turned on in the modules where such quotes +appear. + .. _th-profiling: Using Template Haskell with Profiling diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 5f6bea091a..8e7a7485a2 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -2224,7 +2224,7 @@ parseSpanArg s = do -- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@ -- while simply unpacking 'UnhelpfulSpan's showSrcSpan :: SrcSpan -> String -showSrcSpan (UnhelpfulSpan s) = unpackFS s +showSrcSpan (UnhelpfulSpan s) = unpackFS (unhelpfulSpanFS s) showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn -- | Variant of 'showSrcSpan' for 'RealSrcSpan's diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index 869a6b4a31..7304c20cee 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -341,8 +341,8 @@ processAllTypeCheckedModule tcm = do mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i | otherwise = Nothing - unwrapVar (XExpr (HsWrap _ var)) = var - unwrapVar e' = e' + unwrapVar (XExpr (WrapExpr (HsWrap _ var))) = var + unwrapVar e' = e' -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) diff --git a/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout index cbd4dbeb61..1d16dbf437 100644 --- a/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout +++ b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout @@ -4,4 +4,4 @@ "RealSrcSpan SrcSpanPoint \"filename\" 1 3 Nothing" "RealSrcSpan SrcSpanOneLine \"filename\" 1 3 5 Nothing" "RealSrcSpan SrcSpanMultiLine \"filename\" 1 5 10 1 Nothing" -"UnhelpfulSpan \"bad span\"" +"UnhelpfulSpan (UnhelpfulOther \"bad span\")" diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index 80fc356925..a9081bf7eb 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -540,14 +540,15 @@ (NoExtField) ({ <no location info> } (XExpr - (HsWrap - (WpTyApp - (TyConApp - ({abstract:TyCon}) - [])) - (HsConLikeOut - (NoExtField) - ({abstract:ConLike}))))) + (WrapExpr + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExtField) + ({abstract:ConLike})))))) ({ <no location info> } (HsVar (NoExtField) @@ -564,14 +565,15 @@ (NoExtField) ({ <no location info> } (XExpr - (HsWrap - (WpTyApp - (TyConApp - ({abstract:TyCon}) - [])) - (HsConLikeOut - (NoExtField) - ({abstract:ConLike}))))) + (WrapExpr + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExtField) + ({abstract:ConLike})))))) ({ <no location info> } (HsVar (NoExtField) @@ -588,14 +590,15 @@ (NoExtField) ({ <no location info> } (XExpr - (HsWrap - (WpTyApp - (TyConApp - ({abstract:TyCon}) - [])) - (HsConLikeOut - (NoExtField) - ({abstract:ConLike}))))) + (WrapExpr + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExtField) + ({abstract:ConLike})))))) ({ <no location info> } (HsVar (NoExtField) @@ -603,14 +606,15 @@ {Var: $krep}))))) ({ <no location info> } (XExpr - (HsWrap - (WpTyApp - (TyConApp - ({abstract:TyCon}) - [])) - (HsConLikeOut - (NoExtField) - ({abstract:ConLike}))))))))))))))))))))) + (WrapExpr + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExtField) + ({abstract:ConLike})))))))))))))))))))))) ,({ <no location info> } (VarBind (NoExtField) @@ -632,14 +636,15 @@ {Var: DumpTypecheckedAst.$tcPeano}))))) ({ <no location info> } (XExpr - (HsWrap - (WpTyApp - (TyConApp - ({abstract:TyCon}) - [])) - (HsConLikeOut - (NoExtField) - ({abstract:ConLike}))))))))) + (WrapExpr + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExtField) + ({abstract:ConLike})))))))))) ,({ <no location info> } (VarBind (NoExtField) diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs index 610a0c188e..9481f6e018 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs @@ -53,9 +53,9 @@ typecheckPlugin [name, "typecheck"] _ tc typecheckPlugin _ _ tc = return tc metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc) -metaPlugin' [name, "meta"] (L l (HsPar x (L _ (XExpr (HsWrap w (HsApp noExt (L _ (HsVar _ (L _ id))) e)))))) +metaPlugin' [name, "meta"] (L l (HsPar x (L _ (XExpr (WrapExpr (HsWrap w (HsApp noExt (L _ (HsVar _ (L _ id))) e))))))) | occNameString (getOccName id) == name - = return (L l (XExpr (HsWrap w (unLoc e)))) + = return (L l (XExpr (WrapExpr (HsWrap w (unLoc e))))) -- The test should always match this first case. If the desugaring changes -- again in the future then the panic is more useful than the previous -- inscrutable failure. diff --git a/testsuite/tests/rebindable/all.T b/testsuite/tests/rebindable/all.T index 2caa486d9b..49f77d607e 100644 --- a/testsuite/tests/rebindable/all.T +++ b/testsuite/tests/rebindable/all.T @@ -20,6 +20,8 @@ test('rebindable7', normal, compile_and_run, ['']) test('rebindable8', normal, compile, ['']) test('rebindable9', normal, compile, ['']) test('rebindable10', normal, compile_and_run, ['']) +test('rebindable11', normal, compile_fail, ['']) +test('rebindable12', normal, compile_fail, ['']) test('RebindableFailA', exit_code(1), compile_and_run, ['']) test('RebindableFailB', normal, compile_and_run, ['']) diff --git a/testsuite/tests/rebindable/rebindable11.hs b/testsuite/tests/rebindable/rebindable11.hs new file mode 100644 index 0000000000..747fb232d3 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable11.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE StaticPointers #-} +module Rebindable11 where + +import Prelude + +ifThenElse :: Bool -> () -> () -> Int +ifThenElse cond b1 b2 = 0 + +a1 = let foo = if 'a' then () else () in foo*foo +a2 = (if 'a' then () else ())*2 + 1 +a3 = if 'a' then () else () +a4 = if (if 'a' then () else ()) == 10 then () else () +a5 = static (if 'a' then () else ()) +a6 = (if 'a' then () else ()) :: Int + +data A = A { field :: Int } +a7 = A { field = if 'a' then () else () } +a8 = let someA = A 10 in someA { field = if True == 'a' then () else () } diff --git a/testsuite/tests/rebindable/rebindable11.stderr b/testsuite/tests/rebindable/rebindable11.stderr new file mode 100644 index 0000000000..1aaca7af79 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable11.stderr @@ -0,0 +1,49 @@ + +rebindable11.hs:10:19: error: + • Couldn't match expected type ‘Bool’ with actual type ‘Char’ + • In the expression: 'a' + In the expression: if 'a' then () else () + In an equation for ‘foo’: foo = if 'a' then () else () + +rebindable11.hs:11:10: error: + • Couldn't match expected type ‘Bool’ with actual type ‘Char’ + • In the expression: 'a' + In the first argument of ‘(*)’, namely ‘(if 'a' then () else ())’ + In the first argument of ‘(+)’, namely + ‘(if 'a' then () else ()) * 2’ + +rebindable11.hs:12:9: error: + • Couldn't match expected type ‘Bool’ with actual type ‘Char’ + • In the expression: 'a' + In the expression: if 'a' then () else () + In an equation for ‘a3’: a3 = if 'a' then () else () + +rebindable11.hs:13:13: error: + • Couldn't match expected type ‘Bool’ with actual type ‘Char’ + • In the expression: 'a' + In the first argument of ‘(==)’, namely ‘(if 'a' then () else ())’ + In the expression: (if 'a' then () else ()) == 10 + +rebindable11.hs:14:17: error: + • Couldn't match expected type ‘Bool’ with actual type ‘Char’ + • In the expression: 'a' + In the body of a static form: (if 'a' then () else ()) + In the expression: static (if 'a' then () else ()) + +rebindable11.hs:15:10: error: + • Couldn't match expected type ‘Bool’ with actual type ‘Char’ + • In the expression: 'a' + In the expression: (if 'a' then () else ()) :: Int + In an equation for ‘a6’: a6 = (if 'a' then () else ()) :: Int + +rebindable11.hs:18:21: error: + • Couldn't match expected type ‘Bool’ with actual type ‘Char’ + • In the expression: 'a' + In the ‘field’ field of a record + In the expression: A {field = if 'a' then () else ()} + +rebindable11.hs:19:53: error: + • Couldn't match expected type ‘Bool’ with actual type ‘Char’ + • In the second argument of ‘(==)’, namely ‘'a'’ + In the expression: True == 'a' + In the ‘field’ field of a record diff --git a/testsuite/tests/rebindable/rebindable12.hs b/testsuite/tests/rebindable/rebindable12.hs new file mode 100644 index 0000000000..5fa4d07790 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable12.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE RebindableSyntax #-} +module Rebindable12 where + +import Prelude + +ifThenElse :: Char -> () -> () -> () -> () +ifThenElse _ _ _ _ = () + +y :: () +y = if 'a' then () else () diff --git a/testsuite/tests/rebindable/rebindable12.stderr b/testsuite/tests/rebindable/rebindable12.stderr new file mode 100644 index 0000000000..e6c97e95f6 --- /dev/null +++ b/testsuite/tests/rebindable/rebindable12.stderr @@ -0,0 +1,5 @@ + +rebindable12.hs:10:5: + Couldn't match expected type ‘()’ with actual type ‘() -> ()’ + In the expression: if 'a' then () else () + In an equation for ‘y’: y = if 'a' then () else () diff --git a/testsuite/tests/th/T18102.hs b/testsuite/tests/th/T18102.hs new file mode 100644 index 0000000000..c1dad776da --- /dev/null +++ b/testsuite/tests/th/T18102.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell, RebindableSyntax #-} + +module Bug where + +import Prelude ( Monad(..), Bool(..), print, ($) ) +import Language.Haskell.TH.Syntax + +$( do _stuff <- [| if True then 10 else 15 |] + return [] ) + +$$( do _stuff <- [|| if True then 10 else 15 ||] + return [] ) diff --git a/testsuite/tests/th/T18102.stderr b/testsuite/tests/th/T18102.stderr new file mode 100644 index 0000000000..9c1f1e2484 --- /dev/null +++ b/testsuite/tests/th/T18102.stderr @@ -0,0 +1,25 @@ + +T18102.hs:11:22: error: + • Not in scope: ‘ifThenElse’ + • In the Template Haskell quotation [|| if True then 10 else 15 ||] + In the typed splice: + $$(do _stuff <- [|| if True then 10 else 15 ||] + return []) + +T18102.hs:11:35: error: + • Not in scope: ‘fromInteger’ + Perhaps you want to add ‘fromInteger’ to the import list + in the import of ‘Prelude’ (T18102.hs:5:1-50). + • In the Template Haskell quotation [|| if True then 10 else 15 ||] + In the typed splice: + $$(do _stuff <- [|| if True then 10 else 15 ||] + return []) + +T18102.hs:11:43: error: + • Not in scope: ‘fromInteger’ + Perhaps you want to add ‘fromInteger’ to the import list + in the import of ‘Prelude’ (T18102.hs:5:1-50). + • In the Template Haskell quotation [|| if True then 10 else 15 ||] + In the typed splice: + $$(do _stuff <- [|| if True then 10 else 15 ||] + return []) diff --git a/testsuite/tests/th/T18102b.hs b/testsuite/tests/th/T18102b.hs new file mode 100644 index 0000000000..0f686291de --- /dev/null +++ b/testsuite/tests/th/T18102b.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + +import T18102b_aux + +x :: Int +x = $$(intQuote) + +main :: IO () +main = print x diff --git a/testsuite/tests/th/T18102b.stdout b/testsuite/tests/th/T18102b.stdout new file mode 100644 index 0000000000..410b14d2ce --- /dev/null +++ b/testsuite/tests/th/T18102b.stdout @@ -0,0 +1 @@ +25
\ No newline at end of file diff --git a/testsuite/tests/th/T18102b_aux.hs b/testsuite/tests/th/T18102b_aux.hs new file mode 100644 index 0000000000..f6badf02d7 --- /dev/null +++ b/testsuite/tests/th/T18102b_aux.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE RebindableSyntax, TemplateHaskell #-} +module T18102b_aux where + +import Prelude +import Language.Haskell.TH.Syntax + +ifThenElse :: Bool -> Int -> Int -> Int +ifThenElse _ a b = a+b + +intQuote :: Q (TExp Int) +intQuote = [|| if True then 10 else 15 ||] diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 24cc9d9b46..6d4a5036d7 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -508,6 +508,8 @@ test('T18097', normal, compile, ['']) test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques']) test('TH_StringLift', normal, compile, ['']) test('TH_BytesShowEqOrd', normal, compile_and_run, ['']) +test('T18102', normal, compile_fail, ['']) +test('T18102b', extra_files(['T18102b_aux.hs']), compile_and_run, ['']) test('T18121', normal, compile, ['']) test('T18123', normal, compile, ['']) test('T18388', normal, compile, ['']) |