APIAnnotations:add Locations in hsSyn for layout

Summary:
At the moment ghc-exactprint, which uses the GHC API Annotations to
provide a framework for roundtripping Haskell source code with optional
AST edits, has to implement a horrible workaround to manage the points
where layout needs to be captured.

These are

    MatchGroup
    HsDo
    HsCmdDo
    HsLet
    LetStmt
    HsCmdLet
    GRHSs

To provide a more natural representation, the contents subject to layout
rules need to be wrapped in a SrcSpan.

This commit does this.

Trac ticket #10250

Test Plan: ./validate

Reviewers: hvr, goldfire, bgamari, austin, mpickering

Reviewed By: mpickering

Subscribers: thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D1370

GHC Trac Issues: #10250

1 files changed, 8 insertions, 6 deletions

diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index f804e44f17..384913a1a0 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -388,13 +388,15 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 
 getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
-                               fun_matches = MG { mg_alts = mtchs1 } })) binds
+                               fun_matches
+                                 = MG { mg_alts = L _ mtchs1 } })) binds
   | has_args mtchs1
   = go mtchs1 loc1 binds []
   where
     go mtchs loc
        (L loc2 (ValD (FunBind { fun_id = L _ f2,
-                                fun_matches = MG { mg_alts = mtchs2 } })) : binds) _
+                                fun_matches
+                                  = MG { mg_alts = L _ mtchs2 } })) : binds) _
         | f1 == f2 = go (mtchs2 ++ mtchs)
                         (combineSrcSpans loc loc2) binds []
     go mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
@@ -1115,8 +1117,8 @@ checkCmd _ (HsIf cf ep et ee) = do
     return $ HsCmdIf cf ep pt pe
 checkCmd _ (HsLet lb e) =
     checkCommand e >>= (\c -> return $ HsCmdLet lb c)
-checkCmd _ (HsDo DoExpr stmts ty) =
-    mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo ss ty)
+checkCmd _ (HsDo DoExpr (L l stmts) ty) =
+    mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo (L l ss) ty)
 
 checkCmd _ (OpApp eLeft op _fixity eRight) = do
     -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it
@@ -1145,9 +1147,9 @@ checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
 checkCmdStmt l stmt = cmdStmtFail l stmt
 
 checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName))
-checkCmdMatchGroup mg@(MG { mg_alts = ms }) = do
+checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do
     ms' <- mapM (locMap $ const convert) ms
-    return $ mg { mg_alts = ms' }
+    return $ mg { mg_alts = L l ms' }
     where convert (Match mf pat mty grhss) = do
             grhss' <- checkCmdGRHSs grhss
             return $ Match mf pat mty grhss'