diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index 2b1412b8afe..2cc7f680841 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -47,7 +47,8 @@ module Development.IDE.GHC.ExactPrint ExceptStringT (..), TransformT, Log(..), - insertAtStart', + prependDecl, + prependDeclToWhereDecls, ) where @@ -115,6 +116,8 @@ import GHC.Types.SrcLoc (generatedSrcSpan) import GHC (Anchor(..)) import GHC (AnchorOperation(..)) import GHC (realSrcSpan) +import GHC (EpAnnComments(..)) +import Debug.Trace (traceShowM, trace, traceM) #endif #if MIN_VERSION_ghc(9,2,0) @@ -509,6 +512,62 @@ insertAtStart' old newDecl = do d in newDecl' : secondDecl' : ds insertDeclAtStart _ d ds = d : ds + +prependDeclToWhereDecls decl newWhereDecl = do + traceShowM "tag2" + ds <- balanceCommentsList =<< hsDecls decl + traceShowM "tag3" + let ds' = prependDecl (wrapDecl newWhereDecl) ds + traceShowM "tag4" + replaceDecls decl ds' + +prependDecl :: LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] +prependDecl ldecl = \case + [] -> [setEntryDP ldecl (DifferentLine 1 2)] + ld1:lds -> ldecl':ld1'':lds + where + (ancOp, ld1'') = case ld1 of + L (SrcSpanAnn (EpAnn d1Anc d1Ann (EpaComments (L (Anchor c1Rss cAnc) c1:restCs))) ss) d1 -> + -- NOTE cannot use setEntryDP to simply assign `DL 1 0` here because when there is no prior decl, the + -- DeltaPos on the declaration is absolute instead of relative, and so we must manually update the + -- DeltaPos to be relative (since there is about to be a prior declaration). + let ld1' = L + (SrcSpanAnn + (EpAnn + (setAnchorDp d1Anc $ DifferentLine 1 0) + d1Ann + (EpaCommentsBalanced (L (Anchor c1Rss $ MovedAnchor $ DifferentLine 1 0) c1:restCs) [])) + ss) + d1 + in (cAnc, ld1') + (L (SrcSpanAnn (EpAnn d1Anc d1Ann (EpaCommentsBalanced (L (Anchor c1Rss cAnc) c1:restCs) d1AfterCs)) ss) d1) -> + -- NOTE cannot use setEntryDP to simply assign `DL 1 0` here because when there is no prior decl, the + -- DeltaPos on the declaration is absolute instead of relative, and so we must manually update the + -- DeltaPos to be relative (since there is about to be a prior declaration). + let ld1' = L + (SrcSpanAnn + (EpAnn + (setAnchorDp d1Anc $ DifferentLine 1 0) + d1Ann + (EpaCommentsBalanced (L (Anchor c1Rss $ MovedAnchor $ DifferentLine 1 0) c1:restCs) d1AfterCs)) + ss) + d1 + in (cAnc, ld1') + (L (SrcSpanAnn (EpAnn (Anchor d1Rss d1AncOp) d1Ann epaCs@(EpaComments [])) ss) d1) -> + let ld1' = L (SrcSpanAnn (EpAnn (Anchor d1Rss $ MovedAnchor $ DifferentLine 1 0) d1Ann epaCs) ss) d1 + in (d1AncOp, ld1') + (L (SrcSpanAnn (EpAnn (Anchor d1Rss d1AncOp) d1Ann epaCs@(EpaCommentsBalanced [] _)) ss) d1) -> + let ld1' = L (SrcSpanAnn (EpAnn (Anchor d1Rss $ MovedAnchor $ DifferentLine 1 0) d1Ann epaCs) ss) d1 + in (d1AncOp, ld1') + L (SrcSpanAnn EpAnnNotUsed _) _ -> trace "tag6" error "Unexpected EpAnnNotUsed" + ldecl' = setEntryDP ldecl (maybe (trace "tag7" error "what to do with UnchangedAnchor?") id $ getAnchorOpDp ancOp) + +setAnchorDp :: Anchor -> DeltaPos -> Anchor +setAnchorDp (Anchor rss _) dp = Anchor rss (MovedAnchor dp) + +getAnchorOpDp :: AnchorOperation -> Maybe DeltaPos +getAnchorOpDp (MovedAnchor dp) = Just dp +getAnchorOpDp UnchangedAnchor = Nothing #endif graftSmallestDeclsWithM :: diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index d365fc62289..e6c6dc8e452 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -110,6 +110,8 @@ import GHC (AddEpAnn (Ad EpaLocation (..), LEpaComment, LocatedA) +import Debug.Trace +import Control.Lens (bimap) #else import Language.Haskell.GHC.ExactPrint.Types (Annotation (annsDP), @@ -1008,7 +1010,7 @@ addAsLastArgument (ParsedModule _ parsedSource _ _) range name _typ = -- TODO use typ to initialise type signature addToWhere :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either ResponseError [(T.Text, [TextEdit])] -addToWhere (ParsedModule _ parsedSource _ _) range name _typ = do +addToWhere (ParsedModule _ parsedSource _ _) range name _typ = bimap traceShowId id $ do let mkUnqual name = noLocA $ mkRdrUnqual $ mkVarOcc $ T.unpack name equalAnn dp = AddEpAnn AnnEqual (EpaDelta dp []) addArg = modifySmallestDeclWithM (flip spanContainsRangeOrErr range) $ \case @@ -1027,8 +1029,9 @@ addToWhere (ParsedModule _ parsedSource _ _) range name _typ = do newDeclMatch = noLocA (Match newDeclMatchAnn (FunRhs (mkUnqual name) Prefix SrcStrict) [] grhss) newDeclMg = MG NoExtField (L (noAnnSrcSpanDP0 declMatchSrcSpan) [newDeclMatch]) Generated - newDecl = ValD xVal (FunBind NoExtField (mkUnqual name) newDeclMg []) - hoistTransform (Right . runIdentity) $ insertAtStart' match newDecl + newDecl = (FunBind NoExtField (mkUnqual name) newDeclMg []) + traceShowM "tag1" + prependDeclToWhereDecls match (noLocA newDecl) else pure match let decl' = L locDecl (ValD xVal (FunBind xFunBind idFunBind mg' coreFunBind)) pure [decl'] diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 3a036948063..54a3d629edc 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -2380,8 +2380,8 @@ addFunctionArgumentTests = addToWhereTests :: TestTree addToWhereTests = testGroup - "add to where" - [ testSession "insert new where" $ do + "add_to_where" + [ testSession "insert_new_where" $ do let foo = [ "module Foo where" , "" @@ -2458,9 +2458,8 @@ addToWhereTests = , "bar = 1" , "" , "foo True = _select [True]" - , " where" - , " _select = _" - , " baz = 2" + , " where _select = _" + , " baz = 2" , "foo False = False" ] docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo) @@ -2489,7 +2488,7 @@ addToWhereTests = , "" , "foo True = _select [True]" , " where" - , " _select = _" + , " _select = _" , "foo False = False" ] docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo) @@ -2518,7 +2517,7 @@ addToWhereTests = , "" , "foo True = _select [True]" , " where" - , " _select = _" + , " _select = _" , "foo False = False" ] docB <- createDoc "ModuleB.hs" "haskell" (T.unlines foo) @@ -2552,11 +2551,11 @@ addToWhereTests = executeCodeAction action contentAfterAction <- documentContents docB liftIO $ contentAfterAction @?= T.unlines foo' - , testSession "untyped error" $ do + , testSession "untyped_error" $ do let foo = [ "module Foo where" , "" - , "foo = bar" + , "foo = new_def" , " where" , " -- hi" , " baz = 2" @@ -2564,9 +2563,9 @@ addToWhereTests = foo' = [ "module Foo where" , "" - , "foo = bar" + , "foo = new_def" , " where" - , " bar = _" + , " new_def = _" , " " , " -- hibaz = 2" ] @@ -2575,7 +2574,7 @@ addToWhereTests = InR action@CodeAction { _title = actionTitle } : _ <- filter (\(InR CodeAction{_title=x}) -> "Add to " `isPrefixOf` T.unpack x ) <$> getCodeActions docB (R 2 0 2 50) - liftIO $ actionTitle @?= "Add to where ‘bar’" + liftIO $ actionTitle @?= "Add to where ‘new_def’" executeCodeAction action contentAfterAction <- documentContents docB liftIO $ contentAfterAction @?= T.unlines foo'