Don't insert parentheses for top-level tactics holes (#1352)

* More tests of overlapping methods

* Do a simplification pass of the extract

* Do less work when simplifiying

* Remove unnecessary parens simplification

* Implement simplify as a fold over endos

* Fix tests

* Haddock for the new module

* Minor note on implementation

* Note a TODO

* Use PatCompat to unpack patterns

* Pull out codegen utilities to break a cyclic dependency

* Re-export utils

* No top-level parens for tactics

* Try a different strategy for generalizing PatCompat

* Could this be the answer we've all been waiting for?

* Try, try again to compat

* Reorganize imports

* Fix test

Co-authored-by: Javier Neira <[email protected]>

Author: isovector

ghcide/src/Development/IDE/GHC/ExactPrint.hs

@@ -8,6 +8,7 @@
 module Development.IDE.GHC.ExactPrint
     ( Graft(..),
       graft,
+      graftWithoutParentheses,
       graftDecls,
       graftDeclsWithM,
       annotate,
@@ -179,8 +180,18 @@ graft ::
     SrcSpan ->
     Located ast ->
     Graft (Either String) a
-graft dst val = Graft $ \dflags a -> do
-    (anns, val') <- annotate dflags $ maybeParensAST val
+graft dst = graftWithoutParentheses 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 ::
+    forall ast a.
+    (Data a, ASTElement ast) =>
+    SrcSpan ->
+    Located ast ->
+    Graft (Either String) a
+graftWithoutParentheses dst val = Graft $ \dflags a -> do
+    (anns, val') <- annotate dflags val
     modifyAnnsT $ mappend anns
     pure $
         everywhere'

plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs

@@ -21,6 +21,7 @@ import           Control.Monad.Error.Class (MonadError(throwError))
 import           Control.Monad.Trans
 import           Control.Monad.Trans.Maybe
 import           Data.Aeson
+import           Data.Bool (bool)
 import           Data.Coerce
 import           Data.Functor ((<&>))
 import           Data.Generics.Aliases (mkQ)
@@ -39,7 +40,8 @@ import           Development.IDE.Core.Service (runAction)
 import           Development.IDE.Core.Shake (useWithStale, IdeState (..))
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Error (realSrcSpanToRange)
-import           Development.IDE.GHC.ExactPrint (graft, transform, useAnnotatedSource)
+import           Development.IDE.GHC.ExactPrint (graft, transform, useAnnotatedSource, maybeParensAST)
+import           Development.IDE.GHC.ExactPrint (graftWithoutParentheses)
 import           Development.IDE.Spans.LocalBindings (getDefiningBindings)
 import           Development.Shake (Action)
 import           DynFlags (xopt)
@@ -327,8 +329,11 @@ tacticCmd tac lf state (TacticParams uri range var_name)
                 $ ResponseError InvalidRequest (T.pack $ show err) Nothing
             Right rtr -> do
               traceMX "solns" $ rtr_other_solns rtr
-              traceMX "after simplification" $ rtr_extract rtr
-              let g = graft (RealSrcSpan span) $ rtr_extract rtr
+              traceMX "simplified" $ rtr_extract rtr
+              let g = graftWithoutParentheses (RealSrcSpan span)
+                      -- Parenthesize the extract iff we're not in a top level hole
+                    $ bool maybeParensAST id (_jIsTopHole jdg)
+                    $ rtr_extract rtr
                   response = transform dflags (clientCapabilities lf) uri g pm
               pure $ case response of
                 Right res -> (Right Null , Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res))

test/testdata/tactic/Fgmap.hs.expected

@@ -1,2 +1,2 @@
 fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b))
-fgmap = (fmap . fmap)
+fgmap = fmap . fmap

test/testdata/tactic/FmapBoth.hs.expected

@@ -1,4 +1,4 @@
 fmapBoth :: (Functor f, Functor g) => (a -> b) -> (f a, g a) -> (f b, g b)
-fmapBoth = (\ fab p_faga
-   -> case p_faga of { (fa, ga) -> (fmap fab fa, fmap fab ga) })
+fmapBoth = \ fab p_faga
+  -> case p_faga of { (fa, ga) -> (fmap fab fa, fmap fab ga) }
 

test/testdata/tactic/GoldenArbitrary.hs.expected

@@ -22,31 +22,31 @@ data Obj
 
 
 arbitrary :: Gen Obj
-arbitrary = (let
-               terminal
-                 = [(Square <$> arbitrary) <*> arbitrary, Circle <$> arbitrary,
-                    Polygon <$> arbitrary, pure Empty, pure Full]
-             in
-               sized
-                 $ (\ n
-                      -> case n <= 1 of
-                           True -> oneof terminal
-                           False
-                             -> oneof
-                                  $ ([(Rotate2 <$> arbitrary) <*> scale (subtract 1) arbitrary,
-                                      Complement <$> scale (subtract 1) arbitrary,
-                                      (UnionR <$> arbitrary) <*> scale (subtract 1) arbitrary,
-                                      ((DifferenceR <$> arbitrary) <*> scale (flip div 2) arbitrary)
-                                        <*> scale (flip div 2) arbitrary,
-                                      (IntersectR <$> arbitrary) <*> scale (subtract 1) arbitrary,
-                                      ((Translate <$> arbitrary) <*> arbitrary)
-                                        <*> scale (subtract 1) arbitrary,
-                                      ((Scale <$> arbitrary) <*> arbitrary)
-                                        <*> scale (subtract 1) arbitrary,
-                                      ((Mirror <$> arbitrary) <*> arbitrary)
-                                        <*> scale (subtract 1) arbitrary,
-                                      (Outset <$> arbitrary) <*> scale (subtract 1) arbitrary,
-                                      (Shell <$> arbitrary) <*> scale (subtract 1) arbitrary,
-                                      (WithRounding <$> arbitrary) <*> scale (subtract 1) arbitrary]
-                                       <> terminal)))
+arbitrary = let
+              terminal
+                = [(Square <$> arbitrary) <*> arbitrary, Circle <$> arbitrary,
+                   Polygon <$> arbitrary, pure Empty, pure Full]
+            in
+              sized
+                $ (\ n
+                     -> case n <= 1 of
+                          True -> oneof terminal
+                          False
+                            -> oneof
+                                 $ ([(Rotate2 <$> arbitrary) <*> scale (subtract 1) arbitrary,
+                                     Complement <$> scale (subtract 1) arbitrary,
+                                     (UnionR <$> arbitrary) <*> scale (subtract 1) arbitrary,
+                                     ((DifferenceR <$> arbitrary) <*> scale (flip div 2) arbitrary)
+                                       <*> scale (flip div 2) arbitrary,
+                                     (IntersectR <$> arbitrary) <*> scale (subtract 1) arbitrary,
+                                     ((Translate <$> arbitrary) <*> arbitrary)
+                                       <*> scale (subtract 1) arbitrary,
+                                     ((Scale <$> arbitrary) <*> arbitrary)
+                                       <*> scale (subtract 1) arbitrary,
+                                     ((Mirror <$> arbitrary) <*> arbitrary)
+                                       <*> scale (subtract 1) arbitrary,
+                                     (Outset <$> arbitrary) <*> scale (subtract 1) arbitrary,
+                                     (Shell <$> arbitrary) <*> scale (subtract 1) arbitrary,
+                                     (WithRounding <$> arbitrary) <*> scale (subtract 1) arbitrary]
+                                      <> terminal))
 

test/testdata/tactic/GoldenBigTuple.hs.expected

@@ -1,4 +1,4 @@
 -- There used to be a bug where we were unable to perform a nested split. The
 -- more serious regression test of this is 'AutoTupleSpec'.
 bigTuple :: (a, b, c, d) -> (a, b, (c, d))
-bigTuple = (\ pabcd -> case pabcd of { (a, b, c, d) -> (a, b, (c, d)) })
+bigTuple = \ pabcd -> case pabcd of { (a, b, c, d) -> (a, b, (c, d)) }

test/testdata/tactic/GoldenEitherAuto.hs.expected

@@ -1,5 +1,5 @@
 either' :: (a -> c) -> (b -> c) -> Either a b -> c
-either' = (\ fac fbc eab
-   -> case eab of
-        (Left a) -> fac a
-        (Right b) -> fbc b)
+either' = \ fac fbc eab
+  -> case eab of
+       (Left a) -> fac a
+       (Right b) -> fbc b

test/testdata/tactic/GoldenEitherHomomorphic.hs.expected

@@ -1,5 +1,5 @@
 eitherSplit :: a -> Either (a -> b) (a -> c) -> Either b c
-eitherSplit = (\ a efabfac
-   -> case efabfac of
-        (Left fab) -> Left (fab a)
-        (Right fac) -> Right (fac a))
+eitherSplit = \ a efabfac
+  -> case efabfac of
+       (Left fab) -> Left (fab a)
+       (Right fac) -> Right (fac a)

test/testdata/tactic/GoldenFmapTree.hs.expected

@@ -1,7 +1,7 @@
 data Tree a = Leaf a | Branch (Tree a) (Tree a)
 
 instance Functor Tree where
-   fmap = (\ fab ta
-      -> case ta of
-           (Leaf a) -> Leaf (fab a)
-           (Branch ta2 ta3) -> Branch (fmap fab ta2) (fmap fab ta3))
+   fmap = \ fab ta
+     -> case ta of
+          (Leaf a) -> Leaf (fab a)
+          (Branch ta2 ta3) -> Branch (fmap fab ta2) (fmap fab ta3)

test/testdata/tactic/GoldenFoldr.hs.expected

@@ -1,5 +1,5 @@
 foldr2 :: (a -> b -> b) -> b -> [a] -> b
-foldr2 = (\ f_b b l_a
-   -> case l_a of
-        [] -> b
-        (a : l_a4) -> f_b a (foldr2 f_b b l_a4))
+foldr2 = \ f_b b l_a
+  -> case l_a of
+       [] -> b
+       (a : l_a4) -> f_b a (foldr2 f_b b l_a4)

test/testdata/tactic/GoldenFromMaybe.hs.expected

@@ -1,5 +1,5 @@
 fromMaybe :: a -> Maybe a -> a
-fromMaybe = (\ a ma
-   -> case ma of
-        Nothing -> a
-        (Just a2) -> a2)
+fromMaybe = \ a ma
+  -> case ma of
+       Nothing -> a
+       (Just a2) -> a2

test/testdata/tactic/GoldenGADTAuto.hs.expected

@@ -4,4 +4,4 @@ data CtxGADT a where
   MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT a
 
 ctxGADT :: CtxGADT ()
-ctxGADT = (MkCtxGADT ())
+ctxGADT = MkCtxGADT ()

test/testdata/tactic/GoldenGADTDestruct.hs.expected

@@ -4,4 +4,4 @@ data CtxGADT where
   MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT
 
 ctxGADT :: CtxGADT -> String
-ctxGADT gadt = (case gadt of { (MkCtxGADT a) -> _ })
+ctxGADT gadt = case gadt of { (MkCtxGADT a) -> _ }

test/testdata/tactic/GoldenGADTDestructCoercion.hs.expected

@@ -5,4 +5,4 @@ data E a b where
   E :: forall a b. (b ~ a, Ord a) => b -> E a [a]
 
 ctxGADT :: E a b -> String
-ctxGADT gadt = (case gadt of { (E b) -> _ })
+ctxGADT gadt = case gadt of { (E b) -> _ }

test/testdata/tactic/GoldenIdentityFunctor.hs.expected

@@ -1,3 +1,3 @@
 data Ident a = Ident a
 instance Functor Ident where
-   fmap = (\ fab ia -> case ia of { (Ident a) -> Ident (fab a) })
+   fmap = \ fab ia -> case ia of { (Ident a) -> Ident (fab a) }

test/testdata/tactic/GoldenIntros.hs.expected

@@ -1,2 +1,2 @@
 blah :: Int -> Bool -> (a -> b) -> String -> Int
-blah = (\ i b fab l_c -> _)
+blah = \ i b fab l_c -> _

test/testdata/tactic/GoldenJoinCont.hs.expected

@@ -1,4 +1,4 @@
 type Cont r a = ((a -> r) -> r)
 
 joinCont :: Cont r (Cont r a) -> Cont r a
-joinCont = (\ f_r far -> f_r (\ f_r2 -> f_r2 far))
+joinCont = \ f_r far -> f_r (\ f_r2 -> f_r2 far)

test/testdata/tactic/GoldenListFmap.hs.expected

@@ -1,5 +1,5 @@
 fmapList :: (a -> b) -> [a] -> [b]
-fmapList = (\ fab l_a
-   -> case l_a of
-        [] -> []
-        (a : l_a3) -> fab a : fmapList fab l_a3)
+fmapList = \ fab l_a
+  -> case l_a of
+       [] -> []
+       (a : l_a3) -> fab a : fmapList fab l_a3

test/testdata/tactic/GoldenNote.hs.expected

@@ -1,5 +1,5 @@
 note :: e -> Maybe a -> Either e a
-note = (\ e ma
-   -> case ma of
-        Nothing -> Left e
-        (Just a) -> Right a)
+note = \ e ma
+  -> case ma of
+       Nothing -> Left e
+       (Just a) -> Right a

test/testdata/tactic/GoldenPureList.hs.expected

@@ -1,2 +1,2 @@
 pureList :: a -> [a]
-pureList = (\ a -> a : [])
+pureList = \ a -> a : []

test/testdata/tactic/GoldenSafeHead.hs.expected

@@ -1,5 +1,5 @@
 safeHead :: [x] -> Maybe x
-safeHead = (\ l_x
-   -> case l_x of
-        [] -> Nothing
-        (x : l_x2) -> Just x)
+safeHead = \ l_x
+  -> case l_x of
+       [] -> Nothing
+       (x : l_x2) -> Just x

test/testdata/tactic/GoldenShowCompose.hs.expected

@@ -1,2 +1,2 @@
 showCompose :: Show a => (b -> a) -> b -> String
-showCompose = (\ fba -> show . fba)
+showCompose = \ fba -> show . fba

test/testdata/tactic/GoldenShowMapChar.hs.expected

@@ -1,2 +1,2 @@
 test :: Show a => a -> (String -> b) -> b
-test = (\ a fl_cb -> fl_cb (show a))
+test = \ a fl_cb -> fl_cb (show a)

test/testdata/tactic/GoldenSwap.hs.expected

@@ -1,2 +1,2 @@
 swap :: (a, b) -> (b, a)
-swap = (\ p_ab -> case p_ab of { (a, b) -> (b, a) })
+swap = \ p_ab -> case p_ab of { (a, b) -> (b, a) }

test/testdata/tactic/GoldenSwapMany.hs.expected

@@ -1,2 +1,2 @@
 swapMany :: (a, b, c, d, e) -> (e, d, c, b, a)
-swapMany = (\ pabcde -> case pabcde of { (a, b, c, d, e) -> (e, d, c, b, a) })
+swapMany = \ pabcde -> case pabcde of { (a, b, c, d, e) -> (e, d, c, b, a) }

test/testdata/tactic/RecordCon.hs.expected

@@ -4,6 +4,6 @@ data MyRecord a = Record
     }
 
 blah :: (a -> Int) -> a -> MyRecord a
-blah = (\ fai a -> Record {field1 = a, field2 = fai a})
+blah = \ fai a -> Record {field1 = a, field2 = fai a}