diff --git a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs index f3b82f9835..43eb2cfa6a 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs +++ b/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] diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 2b3d152554..10a09bccd9 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/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 diff --git a/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs index 32e5620b56..205054c652 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs +++ b/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 diff --git a/plugins/hls-tactics-plugin/test/golden/RefineIntroWhere.expected.hs b/plugins/hls-tactics-plugin/test/golden/RefineIntroWhere.expected.hs new file mode 100644 index 0000000000..2d72de4c9b --- /dev/null +++ b/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 + diff --git a/plugins/hls-tactics-plugin/test/golden/RefineIntroWhere.hs b/plugins/hls-tactics-plugin/test/golden/RefineIntroWhere.hs new file mode 100644 index 0000000000..a9e4ca1db7 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/RefineIntroWhere.hs @@ -0,0 +1,6 @@ +test :: Maybe Int -> Int +test = _ + where + -- Don't delete me! + blah = undefined +