[Git][ghc/ghc][master] EPA: More targeted HsDo exact print annotation

13 Sep 2026


      Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
82c73b22 by Alan Zimmerman at 2026-09-12T18:36:38-04:00
EPA: More targeted HsDo exact print annotation

HsDo is multi-purpose, as encoded in its HsDoFlavour field. Some of
these are in a layout context (DoExpr, MDoExpr), others are not
(ListComp, MonadComp).

We are moving towards using AnnList only in layout contexts, so we
switch the HsDo TTG annotation from holding an AnnList for this, to
holding

  Either (EpToken "[", EpToken "]") AnnList

This also allows us to trim down AnnListBrackets to only have braces
or None, thereby opening the door for unification with the existing
layout context data type EpLayout.

- - - - -


10 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/printer/Test20297.stdout
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Utils.hs


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -290,10 +290,12 @@ type instance XLet           GhcPs = (EpToken "let", EpToken "in")
 type instance XLet           GhcRn = NoExtField
 type instance XLet           GhcTc = NoExtField
 
-type instance XDo            GhcPs = (AnnList, EpaLocation)
+type instance XDo            GhcPs = DoAnn
 type instance XDo            GhcRn = NoExtField
 type instance XDo            GhcTc = Type
 
+type DoAnn = (Either (EpToken "[", EpToken "]") AnnList, EpaLocation)
+
 type instance XExplicitList  GhcPs = (EpToken "[", EpToken "]")
 type instance XExplicitList  GhcRn = NoExtField
 type instance XExplicitList  GhcTc = Type
@@ -1467,7 +1469,7 @@ type instance XCmdLet     GhcPs = (EpToken "let", EpToken "in")
 type instance XCmdLet     GhcRn = NoExtField
 type instance XCmdLet     GhcTc = NoExtField
 
-type instance XCmdDo      GhcPs = (AnnList, EpaLocation)
+type instance XCmdDo      GhcPs = DoAnn
 type instance XCmdDo      GhcRn = NoExtField
 type instance XCmdDo      GhcTc = Type
 


=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -335,11 +335,10 @@ mkHsIntegral   :: IntegralLit   GhcPs -> HsOverLit GhcPs
 mkHsFractional :: FractionalLit GhcPs -> HsOverLit GhcPs
 mkHsIsString   :: SourceText -> HText -> HsOverLit GhcPs
 mkHsDo         :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> HsExpr GhcPs
-mkHsDoAnns     :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> (AnnList, EpaLocation) -> HsExpr GhcPs
+mkHsDoAnns     :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> DoAnn -> HsExpr GhcPs
 mkHsComp       :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
                -> HsExpr GhcPs
-mkHsCompAnns   :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
-               -> (AnnList, EpaLocation)
+mkHsCompAnns   :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> DoAnn
                -> HsExpr GhcPs
 
 mkNPat      :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpToken "-"


=====================================
compiler/GHC/Parser.y
=====================================
@@ -3152,19 +3152,15 @@ aexp    :: { ECP }
                                       return $ ECP $
                                         $2 >>= \ $2 ->
                                         mkHsDoPV (comb2 $1 $2)
-                                                 (stmtlistAnns $2)
+                                                 (Right $ stmtlistAnns $2, glR $1)
                                                  (fmap mkModuleNameFS (getDO $1))
-                                                 (stmtlistStmts $2)
-                                                 (glR $1)
-                                                 (glR $2) }
+                                                 (stmtlistStmts $2) }
         | MDO stmtlist             {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->
                                        fmap ecpFromExp $
                                        amsA' (L (comb2 $1 $2)
-                                              (mkMDo (stmtlistAnns $2)
-                                                     (MDoExpr $ fmap mkModuleNameFS (getMDO $1))
-                                                     (stmtlistStmts $2)
-                                                     (glR $1)
-                                                     (glR $2))) }
+                                              (mkHsDoAnns (MDoExpr $ fmap mkModuleNameFS (getMDO $1))
+                                                          (stmtlistStmts $2)
+                                                          (Right $ stmtlistAnns $2, glR $1))) }
         | 'proc' aexp '->' exp
                        {% (checkPattern <=< runPV) (unECP $2) >>= \ p ->
                            runPV (unECP $4) >>= \ $4@cmd ->
@@ -3440,7 +3436,7 @@ list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (
              { \loc (ao,ac) ->
                 checkMonadComp >>= \ ctxt ->
                 unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (epTok $2)
-                ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [], noAnn))
+                ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (Left $ (EpTok ao, EpTok ac), noAnn))
                     >>= ecpFromExp' } }
 
 lexps :: { forall b. DisambECP b => PV [LocatedA b] }
@@ -3658,11 +3654,13 @@ apat    : aexp                  {% (checkPattern <=< runPV) (unECP $1) }
 -----------------------------------------------------------------------------
 -- Statement sequences
 
-stmtlist :: { forall b. DisambECP b => PV (LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), Located [LocatedA (Stmt GhcPs (LocatedA b))])) }
+stmtlist :: { forall b. DisambECP b => PV (LocatedA (AnnList, Located [LocatedA (Stmt GhcPs (LocatedA b))])) }
         : '{'           stmts '}'       { $2 >>= \ $2 ->
-                                          amsA' (sLL $1 $> ((epTok $1, fromOL $ fst $ unLoc $2, epTok $3), sL1 $2 $ reverse $ snd $ unLoc $2))}
+                                          amsA' (sLL $1 $> (AnnList (Just (spanAsAnchor $ stmtsLoc $2)) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2)
+                                                           , sL1 $2 $ reverse $ snd $ unLoc $2))}
         |     vocurly   stmts close     { $2 >>= \ $2 ->
-                                          amsA' (L (stmtsLoc $2) ((noEpTok, fromOL $ fst $ unLoc $2, noEpTok), sL1 $2 $ reverse $ snd $ unLoc $2))}
+                                          amsA' (L (stmtsLoc $2) (AnnList (Just (spanAsAnchor $ stmtsLoc $2)) ListNone (fromOL $ fst $ unLoc $2)
+                                                                 , sL1 $2 $ reverse $ snd $ unLoc $2))}
 
 --      do { ;; s ; s ; ; s ;; }
 -- The last Stmt should be an expression, but that's hard to enforce
@@ -3704,7 +3702,7 @@ e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
 stmt  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
         : qual                          { $1 }
         | 'rec' stmtlist                {  $2 >>= \ $2 ->
-                                           amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) (stmtlistAnns $2) $2)
+                                           amsA' (sLL $1 $> $ mkRecStmt (stmtlistAnns $2, epTok $1)
                                                                         (stmtlistStmts $2)) }
 
 qual  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
@@ -4724,10 +4722,6 @@ commentsPA la@(L l a) = do
   !cs <- getPriorCommentsFor (getLocA la)
   return (L (addCommentsToEpAnn l cs) a)
 
-hsDoAnn :: EpToken "rec" -> (EpToken "{", [EpToken ";"], EpToken "}") -> LocatedAn t b -> (AnnList, EpToken "rec")
-hsDoAnn rec (ob, semis, cb) (L ll _)
-  = (AnnList (Just $ spanAsAnchor (locA ll)) (ListBraces ob cb) semis, rec)
-
 listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation
 listAsAnchorM [] = Nothing
 listAsAnchorM (L l _:_) =
@@ -4757,8 +4751,7 @@ stmtlistStmts :: LocatedA (a, Located [LocatedA (Stmt GhcPs (LocatedA b))])
 stmtlistStmts (L la (_,L l stmts))
   = L ((noAnnSrcSpan l) {comments = comments la}) stmts
 
-stmtlistAnns :: LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), a)
-             -> (EpToken "{", [EpToken ";"], EpToken "}")
+stmtlistAnns :: LocatedA (AnnList, a) -> AnnList
 stmtlistAnns (L _ (an,_)) = an
 
 -- -------------------------------------


=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -519,8 +519,7 @@ data AnnList
       } deriving (Data,Eq)
 
 data AnnListBrackets
-  = ListBraces (EpToken "{")         (EpToken "}")
-  | ListSquare (EpToken "[")         (EpToken "]")
+  = ListBraces (EpToken "{") (EpToken "}")
   | ListNone
   deriving (Data,Eq)
 
@@ -1093,7 +1092,6 @@ instance Outputable AnnList where
 
 instance Outputable AnnListBrackets where
   ppr (ListBraces o c) = text "ListBraces" <+> ppr o <+> ppr c
-  ppr (ListSquare o c) = text "ListSquare" <+> ppr o <+> ppr c
   ppr ListNone         = text "ListNone"
 
 instance Outputable AnnCType where


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Parser.PostProcess (
         mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot
         mkHsOpApp,
         mkHsIntegral, mkHsFractional, mkHsIsString,
-        mkHsDo, mkMDo, mkSpliceDecl,
+        mkHsDo, mkSpliceDecl,
         mkRoleAnnotDecl,
         mkClassDecl,
         mkTyData, mkDataFamInst,
@@ -435,10 +435,6 @@ mkRoleAnnotDecl loc tycon roles anns
             addFatalError $ mkPlainErrorMsgEnvelope loc_role $
               (PsErrIllegalRoleName role nearby)
 
-mkMDo :: (EpToken "{", [EpToken ";"], EpToken "}") -> HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs
-mkMDo (ob, semis, cb) ctxt stmts tok loc
-  = mkHsDoAnns ctxt stmts (AnnList (Just loc) (ListBraces ob cb) semis, tok)
-
 -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to
 -- binders without annotations. Only accepts specified variables, and errors if
 -- any of the provided binders has an 'InferredSpec' annotation.
@@ -1804,12 +1800,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
          -> PV (LocatedA b)
   -- | Disambiguate "do { ... }" (do notation)
   mkHsDoPV ::
-    SrcSpan ->
-    (EpToken "{", [EpToken ";"], EpToken "}") ->
-    Maybe ModuleName ->
-    LocatedA [LStmt GhcPs (LocatedA b)] ->
-    EpaLocation -> -- Token
-    EpaLocation -> -- Anchor
+    SrcSpan -> DoAnn -> Maybe ModuleName -> LocatedA [LStmt GhcPs (LocatedA b)] ->
     PV (LocatedA b)
   -- | Disambiguate "( ... )" (parentheses)
   mkHsParPV :: SrcSpan -> EpToken "(" -> LocatedA b -> EpToken ")" -> PV (LocatedA b)
@@ -1959,10 +1950,10 @@ instance DisambECP (HsCmd GhcPs) where
     checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b
     !cs <- getCommentsFor l
     return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns)
-  mkHsDoPV l (ob,semis,cb) Nothing stmts tok_loc anc = do
+  mkHsDoPV l ann Nothing stmts = do
     !cs <- getCommentsFor l
-    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) (ListBraces ob cb) semis, tok_loc) stmts)
-  mkHsDoPV l _ (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m
+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo ann stmts)
+  mkHsDoPV l _ (Just m) _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m
   mkHsParPV l lpar c rpar = do
     !cs <- getCommentsFor l
     return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c)
@@ -2058,9 +2049,9 @@ instance DisambECP (HsExpr GhcPs) where
     checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b
     !cs <- getCommentsFor l
     return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns)
-  mkHsDoPV l (ob,semis,cb) mod stmts loc_tok anc = do
+  mkHsDoPV l ann mod stmts = do
     !cs <- getCommentsFor l
-    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) (ListBraces ob cb) semis, loc_tok) (DoExpr mod) stmts)
+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo ann (DoExpr mod) stmts)
   mkHsParPV l lpar e rpar = do
     !cs <- getCommentsFor l
     return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e)
@@ -2156,7 +2147,7 @@ instance DisambECP (PatBuilder GhcPs) where
     !cs <- getCommentsFor (locA l)
     return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t))
   mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
-  mkHsDoPV l _ _ _ _ _   = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
+  mkHsDoPV l _ _ _       = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
   mkHsParPV l lpar p rpar   = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
   mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v)
   mkHsLitPV lit@(L l a) = do


=====================================
testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
=====================================
@@ -289,13 +289,12 @@
                      { DumpParsedAstComments.hs:14:7-8 }))]))
                 (HsDo
                  ((,)
-                  (AnnList
-                   (Just
-                    (EpaSpan { DumpParsedAstComments.hs:16:3 }))
-                   (ListBraces
-                    (EpTok (EpaSpan { <no location info> }))
-                    (EpTok (EpaSpan { <no location info> })))
-                   [])
+                  (Right
+                   (AnnList
+                    (Just
+                     (EpaSpan { DumpParsedAstComments.hs:16:3 }))
+                    (ListNone)
+                    []))
                   (EpaSpan { DumpParsedAstComments.hs:14:7-8 }))
                  (DoExpr
                   (Nothing))


=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -331,13 +331,12 @@
                   []))
                 (HsDo
                  ((,)
-                  (AnnList
-                   (Just
-                    (EpaSpan { DumpSemis.hs:(11,3)-(12,3) }))
-                   (ListBraces
-                    (EpTok (EpaSpan { <no location info> }))
-                    (EpTok (EpaSpan { <no location info> })))
-                   [])
+                  (Right
+                   (AnnList
+                    (Just
+                     (EpaSpan { DumpSemis.hs:(11,3)-(12,3) }))
+                    (ListNone)
+                    []))
                   (EpaSpan { DumpSemis.hs:10:7-8 }))
                  (DoExpr
                   (Nothing))
@@ -363,20 +362,21 @@
                         []))
                       (HsDo
                        ((,)
-                        (AnnList
-                         (Just
-                          (EpaSpan { DumpSemis.hs:11:6-15 }))
-                         (ListBraces
-                          (EpTok (EpaSpan { DumpSemis.hs:11:6 }))
-                          (EpTok (EpaSpan { DumpSemis.hs:11:15 })))
-                         [(EpTok
-                           (EpaSpan { DumpSemis.hs:11:8 }))
-                         ,(EpTok
-                           (EpaSpan { DumpSemis.hs:11:9 }))
-                         ,(EpTok
-                           (EpaSpan { DumpSemis.hs:11:10 }))
-                         ,(EpTok
-                           (EpaSpan { DumpSemis.hs:11:11 }))])
+                        (Right
+                         (AnnList
+                          (Just
+                           (EpaSpan { DumpSemis.hs:11:8-13 }))
+                          (ListBraces
+                           (EpTok (EpaSpan { DumpSemis.hs:11:6 }))
+                           (EpTok (EpaSpan { DumpSemis.hs:11:15 })))
+                          [(EpTok
+                            (EpaSpan { DumpSemis.hs:11:8 }))
+                          ,(EpTok
+                            (EpaSpan { DumpSemis.hs:11:9 }))
+                          ,(EpTok
+                            (EpaSpan { DumpSemis.hs:11:10 }))
+                          ,(EpTok
+                            (EpaSpan { DumpSemis.hs:11:11 }))]))
                         (EpaSpan { DumpSemis.hs:11:3-4 }))
                        (DoExpr
                         (Nothing))
@@ -625,16 +625,17 @@
                   []))
                 (HsDo
                  ((,)
-                  (AnnList
-                   (Just
-                    (EpaSpan { DumpSemis.hs:(16,3)-(19,3) }))
-                   (ListBraces
-                    (EpTok (EpaSpan { DumpSemis.hs:16:3 }))
-                    (EpTok (EpaSpan { DumpSemis.hs:19:3 })))
-                   [(EpTok
-                     (EpaSpan { DumpSemis.hs:16:5 }))
-                   ,(EpTok
-                     (EpaSpan { DumpSemis.hs:16:8 }))])
+                  (Right
+                   (AnnList
+                    (Just
+                     (EpaSpan { DumpSemis.hs:(16,5)-(18,5) }))
+                    (ListBraces
+                     (EpTok (EpaSpan { DumpSemis.hs:16:3 }))
+                     (EpTok (EpaSpan { DumpSemis.hs:19:3 })))
+                    [(EpTok
+                      (EpaSpan { DumpSemis.hs:16:5 }))
+                    ,(EpTok
+                      (EpaSpan { DumpSemis.hs:16:8 }))]))
                   (EpaSpan { DumpSemis.hs:15:7-8 }))
                  (DoExpr
                   (Nothing))
@@ -877,16 +878,17 @@
                   []))
                 (HsDo
                  ((,)
-                  (AnnList
-                   (Just
-                    (EpaSpan { DumpSemis.hs:22:10-30 }))
-                   (ListBraces
-                    (EpTok (EpaSpan { DumpSemis.hs:22:10 }))
-                    (EpTok (EpaSpan { DumpSemis.hs:22:30 })))
-                   [(EpTok
-                     (EpaSpan { DumpSemis.hs:22:12 }))
-                   ,(EpTok
-                     (EpaSpan { DumpSemis.hs:22:13 }))])
+                  (Right
+                   (AnnList
+                    (Just
+                     (EpaSpan { DumpSemis.hs:22:12-28 }))
+                    (ListBraces
+                     (EpTok (EpaSpan { DumpSemis.hs:22:10 }))
+                     (EpTok (EpaSpan { DumpSemis.hs:22:30 })))
+                    [(EpTok
+                      (EpaSpan { DumpSemis.hs:22:12 }))
+                    ,(EpTok
+                      (EpaSpan { DumpSemis.hs:22:13 }))]))
                   (EpaSpan { DumpSemis.hs:22:7-8 }))
                  (DoExpr
                   (Nothing))


=====================================
testsuite/tests/printer/Test20297.stdout
=====================================
@@ -394,13 +394,12 @@
                               []))
                             (HsDo
                              ((,)
-                              (AnnList
-                               (Just
-                                (EpaSpan { Test20297.hs:11:22-26 }))
-                               (ListBraces
-                                (EpTok (EpaSpan { <no location info> }))
-                                (EpTok (EpaSpan { <no location info> })))
-                               [])
+                              (Right
+                               (AnnList
+                                (Just
+                                 (EpaSpan { Test20297.hs:11:22-26 }))
+                                (ListNone)
+                                []))
                               (EpaSpan { Test20297.hs:11:19-20 }))
                              (DoExpr
                               (Nothing))
@@ -820,13 +819,12 @@
                               []))
                             (HsDo
                              ((,)
-                              (AnnList
-                               (Just
-                                (EpaSpan { Test20297.ppr.hs:9:20-24 }))
-                               (ListBraces
-                                (EpTok (EpaSpan { <no location info> }))
-                                (EpTok (EpaSpan { <no location info> })))
-                               [])
+                              (Right
+                               (AnnList
+                                (Just
+                                 (EpaSpan { Test20297.ppr.hs:9:20-24 }))
+                                (ListNone)
+                                []))
                               (EpaSpan { Test20297.ppr.hs:9:17-18 }))
                              (DoExpr
                               (Nothing))


=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -980,9 +980,6 @@ markLensBracketsO' a l =
     ListBraces o c -> do
       o' <- markEpToken o
       return (set l (ListBraces o' c) a)
-    ListSquare o c -> do
-      o' <- markEpToken o
-      return (set l (ListSquare o' c) a)
     ListNone -> return (set l ListNone a)
 
 markLensBracketsC :: (Monad m, Monoid w)
@@ -996,9 +993,6 @@ markLensBracketsC' a l =
     ListBraces o c -> do
       c' <- markEpToken c
       return (set l (ListBraces o c') a)
-    ListSquare o c -> do
-      c' <- markEpToken c
-      return (set l (ListSquare o c') a)
     ListNone -> return (set l ListNone a)
 
 -- -------------------------------------
@@ -1468,6 +1462,19 @@ markKwT (AddDarrowAnn tok)  = AddDarrowAnn  <$> markEpUniToken tok
 
 -- ---------------------------------------------------------------------
 
+markAnnListD :: (Monad m, Monoid w)
+  => Either (EpToken "[", EpToken "]") AnnList
+  -> EP w m a
+  -> EP w m (Either (EpToken "[", EpToken "]") AnnList, a)
+markAnnListD (Left (o,c)) action = do
+  o' <- markEpToken o
+  r <- action
+  c' <- markEpToken c
+  return (Left (o',c'), r)
+markAnnListD (Right ann) action = do
+  (ann',r) <- markAnnList' ann action
+  return (Right ann',r)
+
 markAnnList :: (Monad m, Monoid w)
   => EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a)
 markAnnList ann action = do
@@ -3115,10 +3122,10 @@ instance ExactPrint (HsExpr GhcPs) where
       e' <- markAnnotated e
       return (HsLet (tkLet',tkIn') binds' e')
 
-  exact (HsDo (an,l) do_or_list_comp stmts) = do
+  exact (HsDo an do_or_list_comp stmts) = do
     debugM $ "HsDo"
-    (an',l',stmts') <- exactDo (an,l) do_or_list_comp stmts
-    return (HsDo (an',l') do_or_list_comp stmts')
+    (an',stmts') <- exactDo an do_or_list_comp stmts
+    return (HsDo an' do_or_list_comp stmts')
 
   exact (ExplicitList (o,c) es) = do
     debugM $ "ExplicitList start"
@@ -3290,8 +3297,8 @@ instance ExactPrint (HsExpr GhcPs) where
 -- ---------------------------------------------------------------------
 
 exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))
-        => (AnnList, EpaLocation) -> HsDoFlavour -> LocatedAn an a
-        -> EP w m (AnnList, EpaLocation, LocatedAn an a)
+        => DoAnn -> HsDoFlavour -> LocatedAn an a
+        -> EP w m (DoAnn, LocatedAn an a)
 exactDo (an,l) (DoExpr m)    stmts = exactMdo l m "do" >>=
                                    \l0 -> markMaybeDodgyStmts (an,l0) stmts
 exactDo (an,l) GhciStmtCtxt  stmts = printStringAtAA l "do" >>=
@@ -3310,15 +3317,23 @@ exactMdo l (Just module_name) kw = printStringAtAA l n
       n = (moduleNameString module_name) ++ "." ++ kw
 
 markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))
-  => (AnnList, EpaLocation) -> LocatedAn an a -> EP w m (AnnList, EpaLocation, LocatedAn an a)
+  => DoAnn -> LocatedAn an a -> EP w m (DoAnn, LocatedAn an a)
 markMaybeDodgyStmts (an,l) stmts =
   if notDodgy stmts
     then do
-      (an0,stmts') <- markAnnListA' an $ \a -> do
-         r <- markAnnotatedWithLayout stmts
-         return (a, r)
-      return (an0, l, stmts')
-    else return (an, l, stmts)
+      (an0,stmts') <- case an of
+        Left (o,c) -> do
+          o' <- markEpToken o
+          r <- markAnnotated stmts
+          c' <- markEpToken c
+          return (Left (o',c'), r)
+        Right an' -> do
+         (an'',r') <- markAnnListA' an' $ \a -> do
+           r <- markAnnotatedWithLayout stmts
+           return (a, r)
+         return (Right an'',r')
+      return ((an0, l), stmts')
+    else return ((an, l), stmts)
 
 notDodgy :: GenLocated (EpAnn ann) a -> Bool
 notDodgy (L (EpAnn anc _ _) _) = notDodgyE anc
@@ -3601,9 +3616,7 @@ instance ExactPrint (HsCmd GhcPs) where
   exact (HsCmdDo (an0,loc) es) = do
     debugM $ "HsCmdDo"
     loc' <- printStringAtAA loc "do"
-    (an1,es') <- markAnnList' an0 $ do
-      ee <- markAnnotated es
-      return ee
+    (an1,es') <- markAnnListD an0 $ do markAnnotated es
     return (HsCmdDo (an1,loc') es')
 
 -- ---------------------------------------------------------------------


=====================================
utils/check-exact/Utils.hs
=====================================
@@ -343,7 +343,6 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
 
 annListBracketsLocs :: AnnListBrackets -> (EpaLocation,EpaLocation)
 annListBracketsLocs (ListBraces o c) = (getEpTokenLoc o,    getEpTokenLoc c)
-annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o,    getEpTokenLoc c)
 annListBracketsLocs ListNone         = (noAnn,              noAnn)
 
 data SplitWhere = Before | After



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82c73b223a985bc0bcc00cb6252b2b53...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82c73b223a985bc0bcc00cb6252b2b53...
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

    

[Git][ghc/ghc][master] EPA: More targeted HsDo exact print annotation

Marge Bot (＠marge-bot)