Wingman: Don't clobber where clauses (#2184)

* Extend TopLevelRHS pattern to track the where clause

* Don't case split if there's a where clause

* Add tests

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

Author: isovector

plugins/hls-tactics-plugin/src/Wingman/GHC.hs

@@ -309,13 +309,18 @@ type PatCompat pass = LPat pass
 
 ------------------------------------------------------------------------------
 -- | Should make sure it's a fun bind
-pattern TopLevelRHS :: OccName -> [PatCompat GhcTc] -> LHsExpr GhcTc -> Match GhcTc (LHsExpr GhcTc)
-pattern TopLevelRHS name ps body <-
+pattern TopLevelRHS
+    :: OccName
+    -> [PatCompat GhcTc]
+    -> LHsExpr GhcTc
+    -> HsLocalBindsLR GhcTc GhcTc
+    -> Match GhcTc (LHsExpr GhcTc)
+pattern TopLevelRHS name ps body where_binds <-
   Match _
     (FunRhs (L _ (occName -> name)) _ _)
     ps
     (GRHSs _
-      [L _ (GRHS _ [] body)] _)
+      [L _ (GRHS _ [] body)] (L _ where_binds))
 
 
 dataConExTys :: DataCon -> [TyCoVar]

plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs

@@ -273,7 +273,7 @@ mkJudgementAndContext cfg g (TrackedStale binds bmap) rss (TrackedStale tcg tcgm
         mkFirstJudgement
           ctx
           (local_hy <> cls_hy)
-          (isRhsHole tcg_rss tcs)
+          (isRhsHoleWithoutWhere tcg_rss tcs)
           g
     , ctx
     )
@@ -341,6 +341,7 @@ getRhsPosVals (unTrack -> rss) (unTrack -> tcs)
       TopLevelRHS name ps
           (L (RealSrcSpan span)  -- body with no guards and a single defn
             (HsVar _ (L _ hole)))
+          _
         | containsSpan rss span  -- which contains our span
         , isHole $ occName hole  -- and the span is a hole
         -> flip evalState 0 $ buildTopLevelHypothesis name ps
@@ -478,12 +479,25 @@ mkIdHypothesis (splitId -> (name, ty)) prov =
 
 
 ------------------------------------------------------------------------------
--- | Is this hole immediately to the right of an equals sign?
-isRhsHole :: Tracked age RealSrcSpan -> Tracked age TypecheckedSource -> Bool
-isRhsHole (unTrack -> rss) (unTrack -> tcs) =
+-- | Is this hole immediately to the right of an equals sign --- and is there
+-- no where clause attached to it?
+--
+-- It's important that there is no where clause because otherwise it gets
+-- clobbered. See #2183 for an example.
+--
+-- This isn't a perfect check, and produces some ugly code. But it's much much
+-- better than the alternative, which is to destructively modify the user's
+-- AST.
+isRhsHoleWithoutWhere
+    :: Tracked age RealSrcSpan
+    -> Tracked age TypecheckedSource
+    -> Bool
+isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) =
   everything (||) (mkQ False $ \case
-      TopLevelRHS _ _ (L (RealSrcSpan span) _) -> containsSpan rss span
-      _                                        -> False
+      TopLevelRHS _ _
+          (L (RealSrcSpan span) _)
+          (EmptyLocalBinds _) -> containsSpan rss span
+      _                       -> False
     ) tcs
 
 

plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs

@@ -16,6 +16,7 @@ spec = do
     refineTest  2  8 "RefineCon"
     refineTest  4 10 "RefineReader"
     refineTest  8 10 "RefineGADT"
+    refineTest  2  8 "RefineIntroWhere"
 
   describe "messages" $ do
     mkShowMessageTest Refine "" 2 8 "MessageForallA" TacticErrors

plugins/hls-tactics-plugin/test/golden/RefineIntroWhere.expected.hs

@@ -0,0 +1,6 @@
+test :: Maybe Int -> Int
+test = \ m_n -> _w0
+  where
+    -- Don't delete me!
+    blah = undefined
+

plugins/hls-tactics-plugin/test/golden/RefineIntroWhere.hs

@@ -0,0 +1,6 @@
+test :: Maybe Int -> Int
+test = _
+  where
+    -- Don't delete me!
+    blah = undefined
+