diff options
author | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2021-06-10 16:04:26 +0300 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-11-02 01:36:32 -0400 |
commit | f1a782dd29480c4570465ea0aa06008bbf444e13 (patch) | |
tree | 4837a90b7d2e3e1786aa19d75d1d5db5e834f1cf | |
parent | 7445bd714c1bea39207f9a2fa497c325b95ba2c7 (diff) | |
download | haskell-f1a782dd29480c4570465ea0aa06008bbf444e13.tar.gz |
HsToken for let/in (#19623)
One more step towards the new design of EPA.
23 files changed, 97 insertions, 83 deletions
diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs index e059cda6b9..5ba1df580b 100644 --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -57,12 +57,12 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` annotationAddEpAnn `extQ` annotationGrhsAnn `extQ` annotationEpAnnHsCase - `extQ` annotationEpAnnHsLet `extQ` annotationAnnList `extQ` annotationEpAnnImportDecl `extQ` annotationAnnParen `extQ` annotationTrailingAnn `extQ` annotationEpaLocation + `extQ` annotationNoEpAnns `extQ` addEpAnn `extQ` lit `extQ` litr `extQ` litt `extQ` sourceText @@ -242,9 +242,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase") - annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc - annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet") - annotationAnnList :: EpAnn AnnList -> SDoc annotationAnnList = annotation' (text "EpAnn AnnList") @@ -260,6 +257,9 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 annotationEpaLocation :: EpAnn EpaLocation -> SDoc annotationEpaLocation = annotation' (text "EpAnn EpaLocation") + annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc + annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns") + annotation' :: forall a .(Data a, Typeable a) => SDoc -> EpAnn a -> SDoc annotation' tag anns = case ba of diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 4e2dfc9316..eb51021b83 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -311,7 +311,7 @@ type instance XMultiIf GhcPs = EpAnn [AddEpAnn] type instance XMultiIf GhcRn = NoExtField type instance XMultiIf GhcTc = Type -type instance XLet GhcPs = EpAnn AnnsLet +type instance XLet GhcPs = EpAnnCO type instance XLet GhcRn = NoExtField type instance XLet GhcTc = NoExtField @@ -390,12 +390,6 @@ data AnnExplicitSum aesClose :: EpaLocation } deriving Data -data AnnsLet - = AnnsLet { - alLet :: EpaLocation, - alIn :: EpaLocation - } deriving Data - data AnnFieldLabel = AnnFieldLabel { afDot :: Maybe EpaLocation @@ -629,11 +623,11 @@ ppr_expr (HsMultiIf _ alts) ppr_alt (L _ (XGRHS x)) = ppr x -- special case: let ... in let ... -ppr_expr (HsLet _ binds expr@(L _ (HsLet _ _ _))) +ppr_expr (HsLet _ _ binds _ expr@(L _ (HsLet _ _ _ _ _))) = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]), ppr_lexpr expr] -ppr_expr (HsLet _ binds expr) +ppr_expr (HsLet _ _ binds _ expr) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr expr)] @@ -1101,7 +1095,7 @@ type instance XCmdIf GhcPs = EpAnn AnnsIf type instance XCmdIf GhcRn = NoExtField type instance XCmdIf GhcTc = NoExtField -type instance XCmdLet GhcPs = EpAnn AnnsLet +type instance XCmdLet GhcPs = EpAnnCO type instance XCmdLet GhcRn = NoExtField type instance XCmdLet GhcTc = NoExtField @@ -1187,11 +1181,11 @@ ppr_cmd (HsCmdIf _ _ e ct ce) nest 4 (ppr ce)] -- special case: let ... in let ... -ppr_cmd (HsCmdLet _ binds cmd@(L _ (HsCmdLet {}))) +ppr_cmd (HsCmdLet _ _ binds _ cmd@(L _ (HsCmdLet {}))) = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]), ppr_lcmd cmd] -ppr_cmd (HsCmdLet _ binds cmd) +ppr_cmd (HsCmdLet _ _ binds _ cmd) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr cmd)] diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs index f260a4c19b..1501abbb9e 100644 --- a/compiler/GHC/Hs/Syn/Type.hs +++ b/compiler/GHC/Hs/Syn/Type.hs @@ -112,7 +112,7 @@ hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group hsExprType (HsIf _ _ t _) = lhsExprType t hsExprType (HsMultiIf ty _) = ty -hsExprType (HsLet _ _ body) = lhsExprType body +hsExprType (HsLet _ _ _ _ body) = lhsExprType body hsExprType (HsDo ty _ _) = ty hsExprType (ExplicitList ty _) = mkListTy ty hsExprType (RecordCon con_expr _ _) = hsExprType con_expr diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 9833a27f86..3d93e0b7a5 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -567,7 +567,7 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@binds body) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ _ lbinds@binds _ body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds) local_vars' = defined_vars `unionVarSet` local_vars diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 77762c7d64..2e45539fba 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -575,11 +575,11 @@ addTickHsExpr (HsMultiIf ty alts) = do { let isOneOfMany = case alts of [_] -> False; _ -> True ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet x binds e) = - bindLocals (collectLocalBinders CollNoDictBinders binds) $ - liftM2 (HsLet x) - (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsExprLetBody e) +addTickHsExpr (HsLet x tkLet binds tkIn e) = + bindLocals (collectLocalBinders CollNoDictBinders binds) $ do + binds' <- addTickHsLocalBinds binds -- to think about: !patterns. + e' <- addTickLHsExprLetBody e + return (HsLet x tkLet binds' tkIn e') addTickHsExpr (HsDo srcloc cxt (L l stmts)) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) ; return (HsDo srcloc cxt (L l stmts')) } @@ -884,11 +884,11 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet x binds c) = - bindLocals (collectLocalBinders CollNoDictBinders binds) $ - liftM2 (HsCmdLet x) - (addTickHsLocalBinds binds) -- to think about: !patterns. - (addTickLHsCmd c) +addTickHsCmd (HsCmdLet x tkLet binds tkIn c) = + bindLocals (collectLocalBinders CollNoDictBinders binds) $ do + binds' <- addTickHsLocalBinds binds -- to think about: !patterns. + c' <- addTickLHsCmd c + return (HsCmdLet x tkLet binds' tkIn c') addTickHsCmd (HsCmdDo srcloc (L l stmts)) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) ; return (HsCmdDo srcloc (L l stmts')) } diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index a8f14ffdd0..f818be46a1 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -360,7 +360,7 @@ dsExpr (HsCase _ discrim matches) -- Pepe: The binds are in scope in the body but NOT in the binding group -- This is to avoid silliness in breakpoints -dsExpr (HsLet _ binds body) = do +dsExpr (HsLet _ _ binds _ body) = do body' <- dsLExpr body dsLocalBinds binds body' diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 3f47b61375..bb74be0ab9 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1534,7 +1534,7 @@ repE (HsMultiIf _ alts) = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') ; wrapGenSyms (concat binds) expr' } -repE (HsLet _ bs e) = do { (ss,ds) <- repBinds bs +repE (HsLet _ _ bs _ e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 ; wrapGenSyms ss z } diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index e47c90a577..a783833317 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -734,7 +734,7 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where HsPar _ _ e _ -> computeLType e ExplicitTuple{} -> Nothing HsIf _ _ t f -> computeLType t <|> computeLType f - HsLet _ _ body -> computeLType body + HsLet _ _ _ _ body -> computeLType body RecordCon con_expr _ _ -> computeType con_expr ExprWithTySig _ e _ -> computeLType e HsStatic _ e -> computeLType e @@ -1131,7 +1131,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where HsMultiIf _ grhss -> [ toHie grhss ] - HsLet _ binds expr -> + HsLet _ _ binds _ expr -> [ toHie $ RS (mkLScopeA expr) binds , toHie expr ] @@ -1409,7 +1409,7 @@ instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where , toHie b , toHie c ] - HsCmdLet _ binds cmd' -> + HsCmdLet _ _ binds _ cmd' -> [ toHie $ RS (mkLScopeA cmd') binds , toHie cmd' ] diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 6f05f68fb5..fc546c515d 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -2800,8 +2800,7 @@ aexp :: { ECP } , m_grhss = unguardedGRHSs (comb2 $3 (reLoc $4)) $4 (EpAnn (glR $3) (GrhsAnn Nothing (mu AnnRarrow $3)) emptyComments) }])) } | 'let' binds 'in' exp { ECP $ unECP $4 >>= \ $4 -> - mkHsLetPV (comb2A $1 $>) (unLoc $2) $4 - (AnnsLet (glAA $1) (glAA $3)) } + mkHsLetPV (comb2A $1 $>) (hsTok $1) (unLoc $2) (hsTok $3) $4 } | '\\' 'lcase' altslist { ECP $ $3 >>= \ $3 -> mkHsLamCasePV (comb2 $1 (reLoc $>)) $3 [mj AnnLam $1,mj AnnCase $2] } diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index b5511334ec..e553348ea7 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1463,7 +1463,12 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where :: SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b) -- | Disambiguate "let ... in ..." mkHsLetPV - :: SrcSpan -> HsLocalBinds GhcPs -> LocatedA b -> AnnsLet -> PV (LocatedA b) + :: SrcSpan + -> LHsToken "let" GhcPs + -> HsLocalBinds GhcPs + -> LHsToken "in" GhcPs + -> LocatedA b + -> PV (LocatedA b) -- | Infix operator representation type InfixOp b -- | Bring superclass constraints on InfixOp into scope. @@ -1604,9 +1609,9 @@ instance DisambECP (HsCmd GhcPs) where mkHsLamPV l mg = do cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs)) - mkHsLetPV l bs e anns = do + mkHsLetPV l tkLet bs tkIn e = do cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsCmdLet (EpAnn (spanAsAnchor l) anns cs) bs e) + return $ L (noAnnSrcSpan l) (HsCmdLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn e) type InfixOp (HsCmd GhcPs) = HsExpr GhcPs superInfixOp m = m mkHsOpAppPV l c1 op c2 = do @@ -1691,9 +1696,9 @@ instance DisambECP (HsExpr GhcPs) where let mg' = mg cs checkLamMatchGroup l mg' return $ L (noAnnSrcSpan l) (HsLam NoExtField mg') - mkHsLetPV l bs c anns = do + mkHsLetPV l tkLet bs tkIn c = do cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsLet (EpAnn (spanAsAnchor l) anns cs) bs c) + return $ L (noAnnSrcSpan l) (HsLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn c) type InfixOp (HsExpr GhcPs) = HsExpr GhcPs superInfixOp m = m mkHsOpAppPV l e1 op e2 = do @@ -1783,7 +1788,7 @@ instance DisambECP (PatBuilder GhcPs) where ecpFromCmd' (L l c) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c ecpFromExp' (L l e) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e mkHsLamPV l _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat - mkHsLetPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat + mkHsLetPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index e1568d5e01..35129a55cd 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -387,10 +387,10 @@ rnExpr (HsCase _ expr matches) ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches ; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet _ binds expr) +rnExpr (HsLet _ tkLet binds tkIn expr) = rnLocalBindsAndThen binds $ \binds' _ -> do { (expr',fvExpr) <- rnLExpr expr - ; return (HsLet noExtField binds' expr', fvExpr) } + ; return (HsLet noExtField tkLet binds' tkIn expr', fvExpr) } rnExpr (HsDo _ do_or_lc (L l stmts)) = do { ((stmts1, _), fvs1) <- @@ -828,10 +828,10 @@ rnCmd (HsCmdIf _ _ p b1 b2) ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} -rnCmd (HsCmdLet _ binds cmd) +rnCmd (HsCmdLet _ tkLet binds tkIn cmd) = rnLocalBindsAndThen binds $ \ binds' _ -> do { (cmd',fvExpr) <- rnLCmd cmd - ; return (HsCmdLet noExtField binds' cmd', fvExpr) } + ; return (HsCmdLet noExtField tkLet binds' tkIn cmd', fvExpr) } rnCmd (HsCmdDo _ (L l stmts)) = do { ((stmts', _), fvs) <- @@ -859,7 +859,7 @@ methodNamesCmd (HsCmdPar _ _ c _) = methodNamesLCmd c methodNamesCmd (HsCmdIf _ _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdLet _ _ _ _ c) = methodNamesLCmd c methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index 45e8f08a5e..fa6b5ba4c2 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -154,11 +154,11 @@ tc_cmd env (HsCmdPar x lpar cmd rpar) res_ty = do { cmd' <- tcCmd env cmd res_ty ; return (HsCmdPar x lpar cmd' rpar) } -tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty +tc_cmd env (HsCmdLet x tkLet binds tkIn (L body_loc body)) res_ty = do { (binds', body') <- tcLocalBinds binds $ setSrcSpan (locA body_loc) $ tc_cmd env body res_ty - ; return (HsCmdLet x binds' (L body_loc body')) } + ; return (HsCmdLet x tkLet binds' tkIn (L body_loc body')) } tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 077414b96a..87d8560fab 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -366,10 +366,10 @@ tcExpr (ExplicitSum _ alt arity expr) res_ty ************************************************************************ -} -tcExpr (HsLet x binds expr) res_ty +tcExpr (HsLet x tkLet binds tkIn expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ tcMonoExpr expr res_ty - ; return (HsLet x binds' expr') } + ; return (HsLet x tkLet binds' tkIn expr') } tcExpr (HsCase x scrut matches) res_ty = do { -- We used to typecheck the case alternatives first. diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index 25c96b6437..a88bf27480 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -543,7 +543,7 @@ exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches exprCtOrigin (HsIf {}) = IfThenElseOrigin exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs -exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e +exprCtOrigin (HsLet _ _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsDo {}) = DoOrigin exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {}) = RecordUpdOrigin diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 3ac4b13582..142d09f9ee 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -850,10 +850,10 @@ zonkExpr env (HsMultiIf ty alts) ; expr' <- zonkLExpr env' expr ; return $ GRHS x guard' expr' } -zonkExpr env (HsLet x binds expr) +zonkExpr env (HsLet x tkLet binds tkIn expr) = do (new_env, new_binds) <- zonkLocalBinds env binds new_expr <- zonkLExpr new_env expr - return (HsLet x new_binds new_expr) + return (HsLet x tkLet new_binds tkIn new_expr) zonkExpr env (HsDo ty do_or_lc (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts @@ -1027,10 +1027,10 @@ zonkCmd env (HsCmdIf x eCond ePred cThen cElse) ; new_cElse <- zonkLCmd env1 cElse ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } -zonkCmd env (HsCmdLet x binds cmd) +zonkCmd env (HsCmdLet x tkLet binds tkIn cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet x new_binds new_cmd) + return (HsCmdLet x tkLet new_binds tkIn new_cmd) zonkCmd env (HsCmdDo ty (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index eb92fe1240..12b7e9fdbc 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -981,7 +981,7 @@ cvtl e = wrapLA (cvt e) | otherwise = do { alts' <- mapM cvtpair alts ; return $ HsMultiIf noAnn alts' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds - ; e' <- cvtl e; return $ HsLet noAnn ds' e'} + ; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms ; th_origin <- getOrigin ; return $ HsCase noAnn e' diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index e8538dfa43..b472ac9589 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -477,7 +477,9 @@ data HsExpr p -- For details on above see note [exact print annotations] in GHC.Parser.Annotation | HsLet (XLet p) + !(LHsToken "let" p) (HsLocalBinds p) + !(LHsToken "in" p) (LHsExpr p) -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo', @@ -952,7 +954,9 @@ data HsCmd id -- For details on above see note [exact print annotations] in GHC.Parser.Annotation | HsCmdLet (XCmdLet id) + !(LHsToken "let" id) (HsLocalBinds id) -- let(rec) + !(LHsToken "in" id) (LHsCmd id) -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet', -- 'GHC.Parser.Annotation.AnnOpen' @'{'@, diff --git a/testsuite/tests/parser/should_compile/DumpSemis.stderr b/testsuite/tests/parser/should_compile/DumpSemis.stderr index 1b59817f4d..bc3d2cca04 100644 --- a/testsuite/tests/parser/should_compile/DumpSemis.stderr +++ b/testsuite/tests/parser/should_compile/DumpSemis.stderr @@ -1478,11 +1478,13 @@ (Anchor { DumpSemis.hs:34:10-35 } (UnchangedAnchor)) - (AnnsLet - (EpaSpan { DumpSemis.hs:34:10-12 }) - (EpaSpan { DumpSemis.hs:34:32-33 })) + (NoEpAnns) (EpaComments [])) + (L + (TokenLoc + (EpaSpan { DumpSemis.hs:34:10-12 })) + (HsTok)) (HsValBinds (EpAnn (Anchor @@ -1673,6 +1675,10 @@ []))]} [])) (L + (TokenLoc + (EpaSpan { DumpSemis.hs:34:32-33 })) + (HsTok)) + (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:34:35 }) (HsVar (NoExtField) diff --git a/testsuite/tests/typecheck/should_compile/hard_hole_fits.hs b/testsuite/tests/typecheck/should_compile/hard_hole_fits.hs index e523c4eabe..a1cbec4b59 100644 --- a/testsuite/tests/typecheck/should_compile/hard_hole_fits.hs +++ b/testsuite/tests/typecheck/should_compile/hard_hole_fits.hs @@ -31,7 +31,7 @@ testMe (ExplicitSum xes n i gl) = _ testMe (HsCase xc gl mg) = _ testMe (HsIf xi m_se gl gl' ) = _ testMe (HsMultiIf xmi gls) = _ -testMe (HsLet xl gl gl') = _ +testMe (HsLet xl tkLet gl tkIn gl') = _ testMe (HsDo xd hsc gl) = _ testMe (ExplicitList xel m_se) = _ testMe (RecordCon xrc gl hrf) = _ diff --git a/testsuite/tests/typecheck/should_compile/hard_hole_fits.stderr b/testsuite/tests/typecheck/should_compile/hard_hole_fits.stderr index b30f55179b..78a3584f1c 100644 --- a/testsuite/tests/typecheck/should_compile/hard_hole_fits.stderr +++ b/testsuite/tests/typecheck/should_compile/hard_hole_fits.stderr @@ -391,12 +391,17 @@ hard_hole_fits.hs:33:30: warning: [-Wtyped-holes (in -Wdefault)] (imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20 (and originally defined in ‘GHC.Enum’)) -hard_hole_fits.hs:34:28: warning: [-Wtyped-holes (in -Wdefault)] +hard_hole_fits.hs:34:39: warning: [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: Int - • In an equation for ‘testMe’: testMe (HsLet xl gl gl') = _ + • In an equation for ‘testMe’: + testMe (HsLet xl tkLet gl tkIn gl') = _ • Relevant bindings include - gl' :: LHsExpr GhcPs (bound at hard_hole_fits.hs:34:21) + gl' :: LHsExpr GhcPs (bound at hard_hole_fits.hs:34:32) + tkIn :: Language.Haskell.Syntax.Extension.LHsToken "in" GhcPs + (bound at hard_hole_fits.hs:34:27) gl :: Language.Haskell.Syntax.Binds.HsLocalBinds GhcPs + (bound at hard_hole_fits.hs:34:24) + tkLet :: Language.Haskell.Syntax.Extension.LHsToken "let" GhcPs (bound at hard_hole_fits.hs:34:18) xl :: Language.Haskell.Syntax.Extension.XLet GhcPs (bound at hard_hole_fits.hs:34:15) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 7025a0d094..13d6f4869b 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -1830,7 +1830,7 @@ instance ExactPrint (HsExpr GhcPs) where getAnnotationEntry (HsCase an _ _) = fromAnn an getAnnotationEntry (HsIf an _ _ _) = fromAnn an getAnnotationEntry (HsMultiIf an _) = fromAnn an - getAnnotationEntry (HsLet an _ _) = fromAnn an + getAnnotationEntry (HsLet an _ _ _ _) = fromAnn an getAnnotationEntry (HsDo an _ _) = fromAnn an getAnnotationEntry (ExplicitList an _) = fromAnn an getAnnotationEntry (RecordCon an _ _) = fromAnn an @@ -1965,13 +1965,13 @@ instance ExactPrint (HsExpr GhcPs) where markAnnotated mg markEpAnn an AnnCloseC -- optional - exact (HsLet an binds e) = do + exact (HsLet _an tkLet binds tkIn e) = do setLayoutBoth $ do -- Make sure the 'in' gets indented too - markAnnKw an alLet AnnLet + markToken tkLet debugM $ "HSlet:binds coming" setLayoutBoth $ markAnnotated binds debugM $ "HSlet:binds done" - markAnnKw an alIn AnnIn + markToken tkIn debugM $ "HSlet:expr coming" markAnnotated e @@ -2306,7 +2306,7 @@ instance ExactPrint (HsCmd GhcPs) where getAnnotationEntry (HsCmdCase an _ _) = fromAnn an getAnnotationEntry (HsCmdLamCase an _) = fromAnn an getAnnotationEntry (HsCmdIf an _ _ _ _) = fromAnn an - getAnnotationEntry (HsCmdLet an _ _) = fromAnn an + getAnnotationEntry (HsCmdLet an _ _ _ _) = fromAnn an getAnnotationEntry (HsCmdDo an _) = fromAnn an diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index f1a9ed812d..f0617f3bfc 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -435,7 +435,7 @@ changeLetIn1 _libdir parsed = return (everywhere (mkT replace) parsed) where replace :: HsExpr GhcPs -> HsExpr GhcPs - replace (HsLet (EpAnn anc (AnnsLet l _i) cs) localDecls expr) + replace (HsLet an tkLet localDecls _ expr) = let (HsValBinds x (ValBinds xv bagDecls sigs)) = localDecls [l2,_l1] = map wrapDecl $ bagToList bagDecls @@ -443,8 +443,9 @@ changeLetIn1 _libdir parsed (L (SrcSpanAnn _ le) e) = expr a = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan le) (MovedAnchor (SameLine 1))) mempty emptyComments) le) expr' = L a e - in (HsLet (EpAnn anc (AnnsLet l (EpaDelta (DifferentLine 1 0) [])) cs) - (HsValBinds x (ValBinds xv bagDecls' sigs)) expr') + tkIn' = L (TokenLoc (EpaDelta (DifferentLine 1 0) [])) HsTok + in (HsLet an tkLet + (HsValBinds x (ValBinds xv bagDecls' sigs)) tkIn' expr') replace x = x @@ -789,12 +790,12 @@ rmDecl5 _libdir lp = do doRmDecl = do let go :: HsExpr GhcPs -> Transform (HsExpr GhcPs) - go (HsLet a lb expr) = do + go (HsLet a tkLet lb tkIn expr) = do decs <- hsDeclsValBinds lb let dec = last decs _ <- transferEntryDPT (head decs) dec lb' <- replaceDeclsValbinds WithoutWhere lb [dec] - return (HsLet a lb' expr) + return (HsLet a tkLet lb' tkIn expr) go x = return x everywhereM (mkM go) lp diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs index 11c986b644..fc13371f77 100644 --- a/utils/check-exact/Transform.hs +++ b/utils/check-exact/Transform.hs @@ -1172,17 +1172,16 @@ instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where -- --------------------------------------------------------------------- instance HasDecls (LocatedA (HsExpr GhcPs)) where - hsDecls (L _ (HsLet _ decls _ex)) = hsDeclsValBinds decls - hsDecls _ = return [] + hsDecls (L _ (HsLet _ _ decls _ _ex)) = hsDeclsValBinds decls + hsDecls _ = return [] - replaceDecls (L ll (HsLet x binds ex)) newDecls + replaceDecls (L ll (HsLet x tkLet binds tkIn ex)) newDecls = do logTr "replaceDecls HsLet" let lastAnc = realSrcSpan $ spanHsLocaLBinds binds -- TODO: may be an intervening comment, take account for lastAnc - let (x', ex',newDecls') = case x of - EpAnnNotUsed -> (x, ex, newDecls) - (EpAnn a (AnnsLet l i) cs) -> + let (newDecls', tkIn', ex') = case (tkLet, tkIn) of + (L (TokenLoc l) _, L (TokenLoc i) _) -> let off = case l of (EpaSpan r) -> LayoutStartCol $ snd $ ss2pos r @@ -1192,11 +1191,12 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where newDecls'' = case newDecls of [] -> newDecls (d:ds) -> setEntryDPDecl d (SameLine 0) : ds - in ( EpAnn a (AnnsLet l (addEpaLocationDelta off lastAnc i)) cs - , ex'' - , newDecls'') + in ( newDecls'' + , L (TokenLoc (addEpaLocationDelta off lastAnc i)) HsTok + , ex'' ) + _ -> (newDecls, tkIn, ex) binds' <- replaceDeclsValbinds WithoutWhere binds newDecls' - return (L ll (HsLet x' binds' ex')) + return (L ll (HsLet x tkLet binds' tkIn' ex')) -- TODO: does this make sense? Especially as no hsDecls for HsPar replaceDecls (L l (HsPar x lpar e rpar)) newDecls |