From 2290c8bd8c3faee0cb7dc1c2c7951bb9d5e3ebf9 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Fri, 13 Nov 2015 08:39:07 +0200 Subject: 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 --- compiler/deSugar/DsArrows.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) (limited to 'compiler/deSugar/DsArrows.hs') diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 1657a5f49d..14c38b0e9a 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -400,8 +400,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do -- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd dsCmd ids local_vars stack_ty res_ty - (HsCmdLam (MG { mg_alts = [L _ (Match _ pats _ - (GRHSs [L _ (GRHS [] body)] _ ))] })) + (HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _ + (GRHSs [L _ (GRHS [] body)] _ ))] })) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) @@ -505,7 +505,8 @@ case bodies, containing the following fields: -} dsCmd ids local_vars stack_ty res_ty - (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin })) + (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys + , mg_origin = origin })) env_ids = do stack_id <- newSysLocalDs stack_ty @@ -548,7 +549,8 @@ dsCmd ids local_vars stack_ty res_ty (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches in_ty = envStackType env_ids stack_ty - core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys + core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches' + , mg_arg_tys = arg_tys , mg_res_ty = sum_ty, mg_origin = origin })) -- Note that we replace the HsCase result type by sum_ty, -- which is the type of matches' @@ -563,7 +565,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 binds body) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) local_vars' = defined_vars `unionVarSet` local_vars @@ -588,7 +590,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do -- -- ---> premap (\ (env,stk) -> env) c -dsCmd ids local_vars stack_ty res_ty (HsCmdDo stmts _) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdDo (L _ stmts) _) env_ids = do (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids let env_ty = mkBigCoreVarTupTy env_ids core_fst <- mkFstExpr env_ty stack_ty @@ -833,7 +835,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do -- -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss -dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do +dsCmdStmt ids local_vars out_ids (LetStmt (L _ binds)) env_ids = do -- build a new environment using the let bindings core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) -- match the old environment against the input @@ -1048,7 +1050,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" -- List of leaf expressions, with set of variables bound in each leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)] -leavesMatch (L _ (Match _ pats _ (GRHSs grhss binds))) +leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds)))) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` -- cgit v1.2.1