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

2 files changed, 18 insertions, 16 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 40481e5d20..a74d7a8b95 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1323,35 +1323,35 @@ decls   :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) }
         | decl                          { sL1 $1 ([], unitOL $1) }
         | {- empty -}                   { noLoc ([],nilOL) }
 
-decllist :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) }
+decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl RdrName))) }
         : '{'            decls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)
-                                                   ,snd $ unLoc $2) }
-        |     vocurly    decls close   { L (gl $2) (fst $ unLoc $2,snd $ unLoc $2) }
+                                                   ,sL1 $2 $ snd $ unLoc $2) }
+        |     vocurly    decls close   { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }
 
 -- Binding groups other than those of class and instance declarations
 --
-binds   ::  { Located ([AddAnn],HsLocalBinds RdrName) }
+binds   ::  { Located ([AddAnn],Located (HsLocalBinds RdrName)) }
                                          -- May have implicit parameters
                                                 -- No type declarations
-        : decllist          {% do { val_binds <- cvBindGroup (snd $ unLoc $1)
+        : decllist          {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)
                                   ; return (sL1 $1 (fst $ unLoc $1
-                                                    ,HsValBinds val_binds)) } }
+                                                    ,sL1 $1 $ HsValBinds val_binds)) } }
 
         | '{'            dbinds '}'     { sLL $1 $> ([moc $1,mcc $3]
-                                             ,HsIPBinds (IPBinds (unLoc $2)
+                                             ,sL1 $2 $ HsIPBinds (IPBinds (unLoc $2)
                                                          emptyTcEvBinds)) }
 
         |     vocurly    dbinds close   { L (getLoc $2) ([]
-                                            ,HsIPBinds (IPBinds (unLoc $2)
+                                            ,sL1 $2 $ HsIPBinds (IPBinds (unLoc $2)
                                                         emptyTcEvBinds)) }
 
 
-wherebinds :: { Located ([AddAnn],HsLocalBinds RdrName) }
+wherebinds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) }
                                                 -- May have implicit parameters
                                                 -- No type declarations
         : 'where' binds                 { sLL $1 $> (mj AnnWhere $1 : (fst $ unLoc $2)
                                              ,snd $ unLoc $2) }
-        | {- empty -}                   { noLoc ([],emptyLocalBinds) }
+        | {- empty -}                   { noLoc ([],noLoc emptyLocalBinds) }
 
 
 -----------------------------------------------------------------------------
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'