From c98d6b20ab212d2d48bfd02add52f3567db66180 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 3 Mar 2021 20:13:14 -0800 Subject: [PATCH 1/6] Determine when to use parentheses in graft --- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 69 +++++++++++++++++++ .../src/Ide/Plugin/Tactic.hs | 4 +- plugins/hls-tactics-plugin/test/GoldenSpec.hs | 8 +++ .../test/golden/LayoutBind.hs | 6 ++ .../test/golden/LayoutBind.hs.expected | 8 +++ .../test/golden/LayoutDollarApp.hs | 3 + .../test/golden/LayoutDollarApp.hs.expected | 5 ++ .../test/golden/LayoutOpApp.hs | 2 + .../test/golden/LayoutOpApp.hs.expected | 4 ++ 9 files changed, 106 insertions(+), 3 deletions(-) create mode 100644 plugins/hls-tactics-plugin/test/golden/LayoutBind.hs create mode 100644 plugins/hls-tactics-plugin/test/golden/LayoutBind.hs.expected create mode 100644 plugins/hls-tactics-plugin/test/golden/LayoutDollarApp.hs create mode 100644 plugins/hls-tactics-plugin/test/golden/LayoutDollarApp.hs.expected create mode 100644 plugins/hls-tactics-plugin/test/golden/LayoutOpApp.hs create mode 100644 plugins/hls-tactics-plugin/test/golden/LayoutOpApp.hs.expected diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index c571b91248..b76707c180 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -8,6 +8,7 @@ module Development.IDE.GHC.ExactPrint ( Graft(..), graft, + graftExpr, graftWithoutParentheses, graftDecls, graftDeclsWithM, @@ -65,6 +66,8 @@ import Parser (parseIdentifier) import Data.Traversable (for) import Data.Foldable (Foldable(fold)) import Data.Bool (bool) +import GhcPlugins (PprPrec) +import Data.Maybe (catMaybes) #if __GLASGOW_HASKELL__ == 808 import Control.Arrow #endif @@ -178,6 +181,29 @@ transformM dflags ccs uri f a = runExceptT $ let res = printA a' pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions + +needsParens :: HsExpr GhcPs -> Maybe PprPrec +needsParens HsLam{} = Nothing +needsParens HsLamCase{} = Nothing +needsParens HsApp{} = Just appPrec +needsParens HsAppType{} = Just appPrec +needsParens OpApp{} = Just appPrec +needsParens HsPar{} = Nothing +needsParens SectionL{} = Nothing +needsParens SectionR{} = Nothing +needsParens ExplicitTuple{} = Nothing +needsParens ExplicitSum{} = Nothing +needsParens HsCase{} = Nothing +needsParens HsIf{} = Nothing +needsParens HsMultiIf{} = Nothing +needsParens HsLet{} = Nothing +needsParens HsDo{} = Nothing +needsParens ExplicitList{} = Nothing +needsParens RecordCon{} = Nothing +needsParens RecordUpd{} = Just appPrec +needsParens _ = Just appPrec + + ------------------------------------------------------------------------------ {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the @@ -212,6 +238,39 @@ graftWithoutParentheses dst val = Graft $ \dflags a -> do ) a +-- | Like 'graft', but specialized to 'LHsExpr', and intelligently inserts +-- parentheses if they're necessary. +graftExpr :: + forall a. + (Data a) => + SrcSpan -> + LHsExpr GhcPs -> + Graft (Either String) a +graftExpr dst val = Graft $ \dflags a -> do + -- Traverse the tree, looking for our replacement node. But keep track of + -- the context (parent HsExpr constructor) we're in while we do it. This + -- lets us determine wehther or not we need parentheses. + let do_i_need_parens = + everythingWithContext (Nothing :: Maybe PprPrec) (<>) + ( mkQ ([], ) $ \x s -> case x of + (L src _ :: LHsExpr GhcPs) | src == dst -> + ([s], s) + L _ x' -> ([], needsParens x') + ) a + + let needs_parens = not $ null $ catMaybes do_i_need_parens + + (anns, val') <- annotate2 dflags needs_parens $ bool id maybeParensAST needs_parens val + modifyAnnsT $ mappend anns + pure $ + everywhere' + ( mkT $ + \case + (L src _ :: Located ast) | src == dst -> val' + l -> l + ) + a + ------------------------------------------------------------------------------ @@ -402,6 +461,16 @@ annotate dflags ast = do let anns' = setPrecedingLines expr' 0 1 anns pure (anns', expr') +-- | Given an 'LHSExpr', compute its exactprint annotations. +-- Note that this function will throw away any existing annotations (and format) +annotate2 :: ASTElement ast => DynFlags -> Bool -> Located ast -> TransformT (Either String) (Anns, Located ast) +annotate2 dflags needs_space ast = do + uniq <- show <$> uniqueSrcSpanT + let rendered = render dflags ast + (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered + let anns' = setPrecedingLines expr' 0 (bool 0 1 needs_space) anns + pure (anns', expr') + -- | Given an 'LHsDecl', compute its exactprint annotations. annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (Anns, LHsDecl GhcPs) -- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index a936838f0a..ba9d5d3a9d 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -170,9 +170,7 @@ graftHole span rtr $ unLoc $ rtr_extract rtr graftHole span rtr - = graftWithoutParentheses span - -- Parenthesize the extract iff we're not in a top level hole - $ bool maybeParensAST id (_jIsTopHole $ rtr_jdg rtr) + = graftExpr span $ rtr_extract rtr diff --git a/plugins/hls-tactics-plugin/test/GoldenSpec.hs b/plugins/hls-tactics-plugin/test/GoldenSpec.hs index bc60cac658..4f6b63e45c 100644 --- a/plugins/hls-tactics-plugin/test/GoldenSpec.hs +++ b/plugins/hls-tactics-plugin/test/GoldenSpec.hs @@ -73,6 +73,14 @@ spec = do let goldenTest = mkGoldenTest allFeatures + -- test via: + -- stack test hls-tactics-plugin --test-arguments '--match "Golden/layout/"' + describe "layout" $ do + let test = mkGoldenTest allFeatures + test Destruct "b" "LayoutBind.hs" 4 3 + test Destruct "b" "LayoutDollarApp.hs" 2 15 + test Destruct "b" "LayoutOpApp.hs" 2 18 + -- test via: -- stack test hls-tactics-plugin --test-arguments '--match "Golden/destruct all/"' describe "destruct all" $ do diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutBind.hs b/plugins/hls-tactics-plugin/test/golden/LayoutBind.hs new file mode 100644 index 0000000000..4598f0eba1 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutBind.hs @@ -0,0 +1,6 @@ +test :: Bool -> IO () +test b = do + putStrLn "hello" + _ + pure () + diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutBind.hs.expected b/plugins/hls-tactics-plugin/test/golden/LayoutBind.hs.expected new file mode 100644 index 0000000000..fc9ab411ea --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutBind.hs.expected @@ -0,0 +1,8 @@ +test :: Bool -> IO () +test b = do + putStrLn "hello" + case b of + False -> _ + True -> _ + pure () + diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutDollarApp.hs b/plugins/hls-tactics-plugin/test/golden/LayoutDollarApp.hs new file mode 100644 index 0000000000..83a3e4785b --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutDollarApp.hs @@ -0,0 +1,3 @@ +test :: Bool -> Bool +test b = id $ _ + diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutDollarApp.hs.expected b/plugins/hls-tactics-plugin/test/golden/LayoutDollarApp.hs.expected new file mode 100644 index 0000000000..938561984a --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutDollarApp.hs.expected @@ -0,0 +1,5 @@ +test :: Bool -> Bool +test b = id $ (case b of + False -> _ + True -> _) + diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutOpApp.hs b/plugins/hls-tactics-plugin/test/golden/LayoutOpApp.hs new file mode 100644 index 0000000000..a4c05b7539 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutOpApp.hs @@ -0,0 +1,2 @@ +test :: Bool -> Bool +test b = True && _ diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutOpApp.hs.expected b/plugins/hls-tactics-plugin/test/golden/LayoutOpApp.hs.expected new file mode 100644 index 0000000000..520aaed931 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutOpApp.hs.expected @@ -0,0 +1,4 @@ +test :: Bool -> Bool +test b = True && (case b of + False -> _ + True -> _) From e51c44173b5d064b122d39664e659ac3ac4a3795 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 3 Mar 2021 20:37:18 -0800 Subject: [PATCH 2/6] Cleanup the ExactPrint changes --- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 118 +++++++++---------- 1 file changed, 56 insertions(+), 62 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index b76707c180..b5cb909bed 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -9,7 +9,6 @@ module Development.IDE.GHC.ExactPrint ( Graft(..), graft, graftExpr, - graftWithoutParentheses, graftDecls, graftDeclsWithM, annotate, @@ -66,10 +65,9 @@ import Parser (parseIdentifier) import Data.Traversable (for) import Data.Foldable (Foldable(fold)) import Data.Bool (bool) -import GhcPlugins (PprPrec) -import Data.Maybe (catMaybes) #if __GLASGOW_HASKELL__ == 808 import Control.Arrow +import Data.Monoid (All(All)) #endif #if __GLASGOW_HASKELL__ > 808 import Bag (listToBag) @@ -182,33 +180,39 @@ transformM dflags ccs uri f a = runExceptT $ pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions -needsParens :: HsExpr GhcPs -> Maybe PprPrec -needsParens HsLam{} = Nothing -needsParens HsLamCase{} = Nothing -needsParens HsApp{} = Just appPrec -needsParens HsAppType{} = Just appPrec -needsParens OpApp{} = Just appPrec -needsParens HsPar{} = Nothing -needsParens SectionL{} = Nothing -needsParens SectionR{} = Nothing -needsParens ExplicitTuple{} = Nothing -needsParens ExplicitSum{} = Nothing -needsParens HsCase{} = Nothing -needsParens HsIf{} = Nothing -needsParens HsMultiIf{} = Nothing -needsParens HsLet{} = Nothing -needsParens HsDo{} = Nothing -needsParens ExplicitList{} = Nothing -needsParens RecordCon{} = Nothing -needsParens RecordUpd{} = Just appPrec -needsParens _ = Just appPrec +-- | Returns whether or not this node requires its immediate children to have a +needsParensSpace :: + HsExpr GhcPs -> + -- | (Needs parens, needs space) + (All, All) +needsParensSpace HsLam{} = (All False, All False) +needsParensSpace HsLamCase{} = (All False, All False) +needsParensSpace HsApp{} = mempty +needsParensSpace HsAppType{} = mempty +needsParensSpace OpApp{} = mempty +needsParensSpace HsPar{} = (All False, All False) +needsParensSpace SectionL{} = (All False, All False) +needsParensSpace SectionR{} = (All False, All False) +needsParensSpace ExplicitTuple{} = (All False, All False) +needsParensSpace ExplicitSum{} = (All False, All False) +needsParensSpace HsCase{} = (All False, All False) +needsParensSpace HsIf{} = (All False, All False) +needsParensSpace HsMultiIf{} = (All False, All False) +needsParensSpace HsLet{} = (All False, All False) +needsParensSpace HsDo{} = (All False, All False) +needsParensSpace ExplicitList{} = (All False, All False) +needsParensSpace RecordCon{} = (All False, All False) +needsParensSpace RecordUpd{} = mempty +needsParensSpace _ = mempty ------------------------------------------------------------------------------ {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the - given 'LHSExpr'. The node at that position must already be a 'LHsExpr', or - this is a no-op. + given @Located ast@. The node at that position must already be a @Located + ast@, or this is a no-op. + + You want to use 'graftExpr' instead of this function when @ast ~ 'HsExpr'@. -} graft :: forall ast a. @@ -216,18 +220,26 @@ graft :: SrcSpan -> Located ast -> Graft (Either String) a -graft dst = graftWithoutParentheses dst . maybeParensAST +graft dst = graft' True dst . maybeParensAST --- | Like 'graft', but trusts that you have correctly inserted the parentheses --- yourself. If you haven't, the resulting AST will not be valid! -graftWithoutParentheses :: +graft' :: forall ast a. (Data a, ASTElement ast) => + -- | Do we need to insert a space before this grafting? In do blocks, the + -- answer is no, or we will break layout. But in function applications, + -- the answer is yes, or the function call won't get its argument. Yikes! + -- + -- More often the answer is yes, so when in doubt, use that. + -- + -- For a version of this function that does the right thing for + -- expressions without needing to tweak this parameter, look at + -- 'graftExpr'. + Bool -> SrcSpan -> Located ast -> Graft (Either String) a -graftWithoutParentheses dst val = Graft $ \dflags a -> do - (anns, val') <- annotate dflags val +graft' needs_space dst val = Graft $ \dflags a -> do + (anns, val') <- annotate dflags needs_space val modifyAnnsT $ mappend anns pure $ everywhere' @@ -250,26 +262,18 @@ graftExpr dst val = Graft $ \dflags a -> do -- Traverse the tree, looking for our replacement node. But keep track of -- the context (parent HsExpr constructor) we're in while we do it. This -- lets us determine wehther or not we need parentheses. - let do_i_need_parens = - everythingWithContext (Nothing :: Maybe PprPrec) (<>) - ( mkQ ([], ) $ \x s -> case x of + let (All needs_parens, All needs_space) = + everythingWithContext (All True, All True) (<>) + ( mkQ (mempty, ) $ \x s -> case x of (L src _ :: LHsExpr GhcPs) | src == dst -> - ([s], s) - L _ x' -> ([], needsParens x') + (s, s) + L _ x' -> (mempty, needsParensSpace x') ) a - let needs_parens = not $ null $ catMaybes do_i_need_parens - - (anns, val') <- annotate2 dflags needs_parens $ bool id maybeParensAST needs_parens val - modifyAnnsT $ mappend anns - pure $ - everywhere' - ( mkT $ - \case - (L src _ :: Located ast) | src == dst -> val' - l -> l - ) - a + runGraft + (graft' needs_space dst $ bool id maybeParensAST needs_parens val) + dflags + a ------------------------------------------------------------------------------ @@ -291,7 +295,7 @@ graftWithM dst trans = Graft $ \dflags a -> do Just val' -> do (anns, val'') <- hoistTransform (either Fail.fail pure) $ - annotate dflags $ maybeParensAST val' + annotate dflags True $ maybeParensAST val' modifyAnnsT $ mappend anns pure val'' Nothing -> pure val @@ -316,7 +320,7 @@ graftWithSmallestM dst trans = Graft $ \dflags a -> do Just val' -> do (anns, val'') <- hoistTransform (either Fail.fail pure) $ - annotate dflags $ maybeParensAST val' + annotate dflags True $ maybeParensAST val' modifyAnnsT $ mappend anns pure val'' Nothing -> pure val @@ -453,18 +457,8 @@ fixAnns ParsedModule {..} = -- | Given an 'LHSExpr', compute its exactprint annotations. -- Note that this function will throw away any existing annotations (and format) -annotate :: ASTElement ast => DynFlags -> Located ast -> TransformT (Either String) (Anns, Located ast) -annotate dflags ast = do - uniq <- show <$> uniqueSrcSpanT - let rendered = render dflags ast - (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered - let anns' = setPrecedingLines expr' 0 1 anns - pure (anns', expr') - --- | Given an 'LHSExpr', compute its exactprint annotations. --- Note that this function will throw away any existing annotations (and format) -annotate2 :: ASTElement ast => DynFlags -> Bool -> Located ast -> TransformT (Either String) (Anns, Located ast) -annotate2 dflags needs_space ast = do +annotate :: ASTElement ast => DynFlags -> Bool -> Located ast -> TransformT (Either String) (Anns, Located ast) +annotate dflags needs_space ast = do uniq <- show <$> uniqueSrcSpanT let rendered = render dflags ast (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered From bd080364ee693d16f5d953b3c211d0c4a742a792 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 3 Mar 2021 20:39:51 -0800 Subject: [PATCH 3/6] Better comment on needsParensSpace --- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index b5cb909bed..76849d7b39 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -180,7 +180,11 @@ transformM dflags ccs uri f a = runExceptT $ pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions --- | Returns whether or not this node requires its immediate children to have a +-- | Returns whether or not this node requires its immediate children to have +-- be parenthesized and have a leading space. +-- +-- A more natural type for this function would be to return @(Bool, Bool)@, but +-- we use 'All' instead for its monoid instance. needsParensSpace :: HsExpr GhcPs -> -- | (Needs parens, needs space) From 03079ec62b682df2c69c4c449d4666d6919584ac Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 3 Mar 2021 20:55:11 -0800 Subject: [PATCH 4/6] Add lambda layout test --- plugins/hls-tactics-plugin/test/GoldenSpec.hs | 1 + plugins/hls-tactics-plugin/test/golden/LayoutLam.hs | 3 +++ plugins/hls-tactics-plugin/test/golden/LayoutLam.hs.expected | 5 +++++ 3 files changed, 9 insertions(+) create mode 100644 plugins/hls-tactics-plugin/test/golden/LayoutLam.hs create mode 100644 plugins/hls-tactics-plugin/test/golden/LayoutLam.hs.expected diff --git a/plugins/hls-tactics-plugin/test/GoldenSpec.hs b/plugins/hls-tactics-plugin/test/GoldenSpec.hs index 4f6b63e45c..ebdaf01873 100644 --- a/plugins/hls-tactics-plugin/test/GoldenSpec.hs +++ b/plugins/hls-tactics-plugin/test/GoldenSpec.hs @@ -80,6 +80,7 @@ spec = do test Destruct "b" "LayoutBind.hs" 4 3 test Destruct "b" "LayoutDollarApp.hs" 2 15 test Destruct "b" "LayoutOpApp.hs" 2 18 + test Destruct "b" "LayoutLam.hs" 2 14 -- test via: -- stack test hls-tactics-plugin --test-arguments '--match "Golden/destruct all/"' diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutLam.hs b/plugins/hls-tactics-plugin/test/golden/LayoutLam.hs new file mode 100644 index 0000000000..3fead2a25d --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutLam.hs @@ -0,0 +1,3 @@ +test :: Bool -> Bool +test = \b -> _ + diff --git a/plugins/hls-tactics-plugin/test/golden/LayoutLam.hs.expected b/plugins/hls-tactics-plugin/test/golden/LayoutLam.hs.expected new file mode 100644 index 0000000000..e0b2ac2ddf --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/LayoutLam.hs.expected @@ -0,0 +1,5 @@ +test :: Bool -> Bool +test = \b -> case b of + False -> _ + True -> _ + From 970889122c019dcfb520ccc4f487fa402f449c5f Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 3 Mar 2021 21:17:43 -0800 Subject: [PATCH 5/6] Import code action put the import in a stupid place :( --- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index 76849d7b39..7384762ebb 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -65,9 +65,9 @@ import Parser (parseIdentifier) import Data.Traversable (for) import Data.Foldable (Foldable(fold)) import Data.Bool (bool) +import Data.Monoid (All(All)) #if __GLASGOW_HASKELL__ == 808 import Control.Arrow -import Data.Monoid (All(All)) #endif #if __GLASGOW_HASKELL__ > 808 import Bag (listToBag) From 0f40d012fa59261f0a6086fe2a50cc2e9e78c3f9 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 3 Mar 2021 23:25:25 -0800 Subject: [PATCH 6/6] Make graft a method so it can delegate to graftExpr --- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 28 ++++++++----------- .../src/Ide/Plugin/Tactic.hs | 2 +- 2 files changed, 13 insertions(+), 17 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index 7384762ebb..9f3280e86c 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -7,8 +7,6 @@ module Development.IDE.GHC.ExactPrint ( Graft(..), - graft, - graftExpr, graftDecls, graftDeclsWithM, annotate, @@ -215,17 +213,7 @@ needsParensSpace _ = mempty {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the given @Located ast@. The node at that position must already be a @Located ast@, or this is a no-op. - - You want to use 'graftExpr' instead of this function when @ast ~ 'HsExpr'@. -} -graft :: - forall ast a. - (Data a, ASTElement ast) => - SrcSpan -> - Located ast -> - Graft (Either String) a -graft dst = graft' True dst . maybeParensAST - graft' :: forall ast a. (Data a, ASTElement ast) => @@ -234,10 +222,6 @@ graft' :: -- the answer is yes, or the function call won't get its argument. Yikes! -- -- More often the answer is yes, so when in doubt, use that. - -- - -- For a version of this function that does the right thing for - -- expressions without needing to tweak this parameter, look at - -- 'graftExpr'. Bool -> SrcSpan -> Located ast -> @@ -419,10 +403,22 @@ everywhereM' f = go class (Data ast, Outputable ast) => ASTElement ast where parseAST :: Parser (Located ast) maybeParensAST :: Located ast -> Located ast + {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with + the given @Located ast@. The node at that position must already be + a @Located ast@, or this is a no-op. + -} + graft :: + forall a. + (Data a) => + SrcSpan -> + Located ast -> + Graft (Either String) a + graft dst = graft' True dst . maybeParensAST instance p ~ GhcPs => ASTElement (HsExpr p) where parseAST = parseExpr maybeParensAST = parenthesize + graft = graftExpr instance p ~ GhcPs => ASTElement (Pat p) where #if __GLASGOW_HASKELL__ == 808 diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index ba9d5d3a9d..69c28c7109 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -170,7 +170,7 @@ graftHole span rtr $ unLoc $ rtr_extract rtr graftHole span rtr - = graftExpr span + = graft span $ rtr_extract rtr